home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 101-125 / disk_104 / analyticalc / src / analysrc.arc / AnalyAC.Ftn < prev    next >
Text File  |  1987-10-06  |  100KB  |  3,939 lines
  1. c -h- analy.for    Fri Aug 22 12:54:45 1986    
  2.        PROGRAM ANALY(INPUT=15,OUTPUT=16,TAPE=17,ERR=1)
  3. C PORTACALC MAIN PROGRAM
  4. C SPREAD SHEET DRIVER PROGRAM
  5. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  6. C ALL RIGHTS RESERVED
  7. C MAX SHEET DIMS ARE 60 BY 300 (301 SINCE ACCUMULATORS ARE A PSEUDO ROW)
  8. C PARAMETER 18060=60*301
  9. C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
  10. C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
  11. C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
  12. C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
  13. C FROM THE DISK BASED FILE HERE.
  14. C
  15.     InTeGer*4 PRL(6)
  16.         CHARACTER*1 NOWRAP ( 2 )
  17.     CHARACTER*1 FORM,FVLD,CMDLIN(132)
  18.     INTEGER*4 VNLT
  19.     INTEGER IFCW
  20. C    EXTERNAL LCWRQQ
  21.     DIMENSION FORM(128),FVLD(1,1)
  22. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  23. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  24. C SO INITIALLY IGNORE.
  25. C
  26. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  27. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  28. C
  29. C ***<<<< RDD COMMON START >>>***
  30.     InTeGer*4 RRWACT,RCLACT
  31. C    COMMON/RCLACT/RRWACT,RCLACT
  32.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  33.      1  IDOL7,IDOL8
  34. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  35. C     1  IDOL7,IDOL8
  36.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  37. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  38.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  39. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  40. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  41. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  42.     InTeGer*4 KLVL
  43. C    COMMON/KLVL/KLVL
  44.     InTeGer*4 IOLVL,IGOLD
  45. C    COMMON/IOLVL/IOLVL
  46. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  47. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  48.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  49.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  50.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  51. C ***<<< RDD COMMON END >>>***
  52.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  53.     COMMON/D2R/NRDSP,NCDSP
  54.     InTeGer*4 TYPE(1,1),VLEN(9)
  55.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  56.     REAL*8 XXV(1,1)
  57.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  58.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  59. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  60.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  61.     EQUIVALENCE(DVFMT(2),DEFFMT(1))
  62.     CHARACTER*12 CDVFMT
  63.     EQUIVALENCE(CDVFMT(1:1),DVFMT(1))
  64.     COMMON/DEFVBX/DVFMT
  65.     CHARACTER*1 NMSH(80)
  66.     CHARACTER*80 NMSH80
  67.     EQUIVALENCE(NMSH80(1:1),NMSH(1))
  68.     COMMON/NMSH/NMSH
  69.     CHARACTER*1 FORM2(4)
  70. C ***<<< XVXTCD COMMON START >>>***
  71.     CHARACTER*1 OARRY(100)
  72.     InTeGer*4 OSWIT,OCNTR
  73. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  74. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  75.     InTeGer*4 IPS1,IPS2,MODFLG
  76. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  77.        InTeGer*4 XTCFG,IPSET,XTNCNT
  78.        CHARACTER*1 XTNCMD(80)
  79. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  80. C VARY FLAG ITERATION COUNT
  81.     INTEGER KALKIT
  82. C    COMMON/VARYIT/KALKIT
  83.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  84.     InTeGer*4 RCMODE,IRCE1,IRCE2
  85. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  86. C     1  IRCE2
  87. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  88. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  89. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  90. C RCFGX ON.
  91. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  92. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  93. C  AND VM INHIBITS. (SETS TO 1).
  94.     INTEGER*4 FH
  95. C FILE HANDLE FOR CONSOLE I/O (RAW)
  96. C    COMMON/CONSFH/FH
  97.     CHARACTER*1 ARGSTR(52,4)
  98. C    COMMON/ARGSTR/ARGSTR
  99.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  100.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  101.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  102.      3  IRCE2,FH,ARGSTR
  103. C ***<<< XVXTCD COMMON END >>>***
  104. C
  105. C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
  106. C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
  107. C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
  108. C DISPLAY ACTUALLY USED FOR SCREEN.
  109.     InTeGer*4 CWIDS(20)
  110. C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
  111. C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
  112. C AS 20 NOT 75.
  113.     INTEGER*4 I4TMP
  114.     REAL*8 DVS(20,75)
  115.     COMMON /FVLDC/FVLD
  116. C FOLLOWING SUPPORT VVARY OVERLAY:
  117.     REAL*8 QQAC(26),QDERIV(8),QDEL(8),OLDVV,OLDX,OLDA
  118.     InTeGer*4 QCAC,QCENT(8),ACV(8)
  119.     COMMON/VRYDAT/QQAC,QDERIV,QDEL,QCAC,QCENT,OLDVV,OLDX,OLDA,ACV
  120. C BITMAP
  121. C    CHARACTER*1 IBITMP
  122. C    DIMENSION IBITMP(2258)
  123. C    COMMON/INITD/IBITMP
  124. C    CHARACTER*1 DFMTS(10,20,75)
  125. C 10 CHARACTERS PER ENTRY.
  126.     COMMON/DSPCMN/DVS,CWIDS
  127. C    character*35 fwt
  128. C COMMONS FROM OTHER MISC. ROUTINES, ADDED TO ALLOW AMIGA FORTRAN TO
  129. C ALLOCATE COMMONS ON STACK...
  130.     CHARACTER*1 LBITS(8)
  131.     COMMON/BITS/LBITS
  132.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  133.     COMMON/CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  134.     CHARACTER*1 DTBL1(9,9,8)
  135.     COMMON/DECIDE/DTBL1
  136.     CHARACTER*1 DIGITS(16,3)
  137.     COMMON/DIGV/DIGITS
  138. C ***<<< KLSTO COMMON START >>>***
  139.     InTeGer*4 DLFG
  140. C    COMMON/DLFG/DLFG
  141.     InTeGer*4 KDRW,KDCL
  142. C    COMMON/DOT/KDRW,KDCL
  143.     InTeGer*4 DTRENA
  144. C    COMMON/DTRCMN/DTRENA
  145.     REAL*8 EP,PV,FV
  146.     DIMENSION EP(20)
  147.     INTEGER*4 KIRR
  148. C    COMMON/ERNPER/EP,PV,FV,KIRR
  149.     InTeGer*4 LASTOP
  150. C    COMMON/ERROR/LASTOP
  151.     CHARACTER*1 FMTDAT(9,76)
  152. C    COMMON/FMTBFR/FMTDAT
  153.     CHARACTER*1 EDNAM(16)
  154. C    COMMON/EDNAM/EDNAM
  155.     InTeGer*4 MFID(2),MFMOD(2)
  156. C    COMMON/FRM/MFID,MFMOD
  157.     InTeGer*4 JMVFG,JMVOLD
  158. C    COMMON/FUBAR/JMVFG,JMVOLD
  159.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  160.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  161. C ***<<< KLSTO COMMON END >>>***
  162. C
  163. C
  164.         CHARACTER*1 FV1(2264),FV2(2264),FV4(2264)
  165.     CHARACTER*1 FVXX(6792)
  166.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
  167.     EQUIVALENCE (FV4(1),FVXX(4529))
  168.         Common/FVLDM/FVXX
  169. c        COMMON/FVLDM/FV1,FV2,FV4
  170.     InTeGer*2 IFID(8,2048)
  171.     COMMON/IFIDC/IFID
  172.     InTeGer*4 ILNFG,ILNCT
  173.     CHARACTER*1 ILINE(106)
  174.     COMMON/ILN/ILNFG,ILNCT,ILINE
  175.     InTeGer*4 ITCNTV(6)
  176.     COMMON/ITERA/ITCNTV
  177.     InTeGer*4 MFIOPN,MFIRL,MFIRH,MFICL,MFICH
  178.     InTeGer*4 MFOOPN,MFORL,MFORH,MFOCL,MFOCH
  179.     InTeGer*4 MFILUN,MFOLUN,MFIFLG,MFOFLG
  180.     COMMON/MFILES/MFIOPN,MFOOPN,MFIRL,MFIRH,MFICL,MFICH,
  181.      1  MFORL,MFORH,MFOCL,MFOCH,MFILUN,MFOLUN,MFIFLG,MFOFLG
  182. C ***<<< NULETC COMMON START >>>***
  183.     InTeGer*4 ICREF,IRREF
  184. C    COMMON/MIRROR/ICREF,IRREF
  185.     InTeGer*4 MODPUB,LIMODE
  186. C    COMMON/MODPUB/MODPUB,LIMODE
  187.     InTeGer*4 KLKC,KLKR
  188.     REAL*8 AACP,AACQ
  189. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  190.     InTeGer*4 NCEL,NXINI
  191. C    COMMON/NCEL/NCEL,NXINI
  192.     CHARACTER*1 NAMARY(20,301)
  193. C    COMMON/NMNMNM/NAMARY
  194.     InTeGer*4 NULAST,LFVD
  195. C    COMMON/NULXXX/NULAST,LFVD
  196.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  197.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  198. C ***<<< NULETC COMMON END >>>***
  199.     CHARACTER*1 STACK1(8,40),STACK2(8,40)
  200.     InTeGer*4 ST1PT,ST2PT,ST1TYP(40),ST2TYP(40),ST1LIM,ST2LIM
  201.     COMMON/STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  202.      1  ST1LIM,ST2LIM
  203.     InTeGer*4 IATYP(27),LINTGR
  204.     CHARACTER*1 ITYP(2264)
  205.     COMMON/TYP/IATYP,ITYP,LINTGR
  206.     InTeGer*4 MPAG(2),MPMOD(2)
  207.     InTeGer*2 LVALBF(5,800)
  208.     COMMON/VB/MPAG,LVALBF,MPMOD
  209.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  210.     COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
  211.     InTeGer*4 LEVEL,NONBLK,LEND,VIEWSW,BASED
  212.     CHARACTER*1 LINE(80)
  213.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  214. C *** END COMMONS FROM OTHER PLACES.
  215.     FH=0
  216. c    IFCW=4927
  217. C DISABLE FLOATING EXCEPTIONS
  218. c    CALL LCWRQQ(IFCW)
  219. C INITIAL DEFAULT FORMAT FOR NUMERICS is set at runtime
  220. C INIT COMMON DATA FIRST OF ALL.
  221.     IDOL7=1
  222. C INITIALLY IN ANSI MODE. STILL USE ANSI DRIVER FOR INPUT CONTROLS.
  223. C NOW SET UP OTHER COMMON INFO (USED TO BE A BLOCK DATA...NOW CHANGED.)
  224.     CALL BLOCK
  225.     IKONS=0
  226.     CALL INITA1(KMAP,KWID,ICODE)
  227. 3002    CONTINUE
  228.     CALL INITA2(KMAP,KWID,ICODE,IKONS)
  229.     IKONS=1
  230. 3000    CONTINUE
  231.     CALL INITB(KMAP,KWID,ICODE)
  232.     LINIZZ=0
  233. d    Write(*,1787)FH
  234. d1787   Format(' console dataset pointer FH=',I12)
  235. C    IF(IOLDFL.GT.1)GOTO 2000
  236. 2000    CONTINUE
  237. C DRAW OUR LABELS AND OTHERWISE INITIALIZE DISPLAY SHEET
  238.     KZPPD=0
  239.     IF(IPSET.NE.0)GOTO 1000
  240.     IF(PZAP.EQ.0)CALL UVT100(11,2,0)
  241.     CALL UVT100(1,1,1)
  242.     OSWIT=20
  243.     IPRSS=PROW
  244.     IPCSS=PCOL
  245.     IDRW=DROW
  246.     IDCL=DCOL
  247.     IF(LINIZZ.LE.1)CALL RECALC
  248.     IF(PZAP.EQ.0)CALL DSPSHT(2)
  249.     DCOL=IDCL
  250.     DROW=IDRW
  251.     PROW=IPRSS
  252.     PCOL=IPCSS
  253. 3006    FORMAT(80A1)
  254. C
  255. 1000    CONTINUE
  256.     IPSET=0
  257.     LINIZZ=LINIZZ+1
  258.     OSWIT=20
  259. C ISSUE A PROMPT FOR COMMAND AND DO A COMMAND
  260.     ICODE=0
  261.     CALL XQTCMD(ICODE)
  262.     IF(ICODE.LT.30)GOTO 1843
  263. C HELP COMMAND AND SIMILAR...
  264.     IF(ICODE.NE.400)GOTO 1847
  265.     CALL DSPSHT(10)
  266.     ICODE=1
  267. C CODE 10 IS PRINT SECRET CODE TO DSPSHT.
  268.     GOTO 1843
  269. 1847    CONTINUE
  270.     IF(ICODE.NE.420)GOTO 1849
  271. C CLOSE UNIT 1 JUST IN CASE...
  272.     CLOSE(1)
  273.     KLVL=1
  274.     IPRSSS=PROW
  275.     IPCSSS=PCOL
  276.     CALL CALC
  277.     PROW=IPRSSS
  278.     PCOL=IPCSSS
  279. C CLOSE CONSOLE LUN USED BY CALC.
  280.     CLOSE(1)
  281. C CLOSE ANY OTHER LUNS CALC MAY HAVE USED...
  282.     CLOSE(2)
  283.     CLOSE(3)
  284. C SET UP FOR REDRAW WHEN BACK...
  285.     ICODE=-1
  286.     GOTO 1843
  287. 1849    CONTINUE
  288.     IF(ICODE.NE.430)GOTO 1845
  289. C TEST FUNCTION, TESTING EXPRESSION.
  290. C INHIBIT RECALCULATION...
  291. C COMMAND IS IN "XTNCMD" STRING.
  292.     LLST=MIN0(80,XTNCNT)
  293.     LFST=1
  294.     CALL DOENTR(XTNCMD,LFST,LLST)
  295. C THIS SETS % VARIABLE AND WILL DO A CALC DIRECTLY. THEREFORE
  296. C WE MUST INHIBIT AUTO RECALCULATION.
  297. C NOTE WE HAVE TO CALL THIS FROM THE ROOT SINCE THE RECALC OVERLAY
  298. C TREE OVERWRITES THE XQTCMD ONE.
  299.     ICODE=1
  300.     GOTO 1843
  301. 1845    CONTINUE
  302.     IVVV=ICODE-30
  303. 9308    CALL HELP(IVVV)
  304.     IVVV=0
  305.     CALL VWRT('Type return to continue, Hn for other Help pages:',
  306.      1  49)
  307.     ILL=IOLVL
  308. C    IF(ILL.EQ.5)ILL=0
  309.     READ(ILL,3006,END=5600,ERR=5600)(FORM2(K),K=1,4)
  310.     IVVVV=ichar(FORM2(2))
  311.     IF(IVVVV.GE.48.AND.IVVVV.LE.57)IVVV=IVVVV-48
  312.     IF(FORM2(1).EQ.'H'.OR.FORM2(1).EQ.'h')GOTO 9308
  313. C NOW CLEAR SCREEN AND TRY MORE COMMANDS AS BEFORE...
  314.     ICODE=6
  315. C
  316. 1843    CONTINUE
  317.     OSWIT=20
  318.     IPRSS=PROW
  319.     IPCSS=PCOL
  320.     IDRW=DROW
  321.     IDCL=DCOL
  322.     IF(LINIZZ.LE.1)CALL RECALC
  323.     IF(IPSET.NE.0)GOTO 4110
  324.     DCOL=IDCL
  325.     DROW=IDRW
  326.     PROW=IPRSS
  327.     PCOL=IPCSS
  328. 4110    CONTINUE
  329.     IPSET=0
  330.     IF(ICODE.EQ.-1)GOTO 2000
  331. C IN PORTACALC-VM, S COMMAND ALLOWS DEFAULT FORMAT CHANGE AND
  332. C TITLE CHANGE, BUT DOES NOT ALTER SHEET IN MEMORY... DON'T ALLOW
  333. C SCRATCH FILE SAVE STUFF...
  334. C    IF(ICODE.EQ.-2)CALL WRKFIL(1,FORM,3)
  335. C    IF (ICODE.EQ.-2)CALL CLOSE(7)
  336.     IF(ICODE.LE.-2)GOTO 3002
  337. C
  338. C RECALCULATE SHEET NOW AUTOMAGICALLY
  339. C IF ICODE=1, COMMAND JUST MOVES ON DISPLAY, SO NO NEED TO RECALCULATE
  340. C THE ENTIRE SHEET.
  341. C LIMIT NUMBER OF ITERATIONS AT ANY ONE TIME TO 20 HOWEVER
  342.     KKMAX=20
  343. 3670    CONTINUE
  344.     IF(ICODE.EQ.5.OR.ICODE.EQ.1
  345.      1  .OR.ICODE.EQ.6.OR.RCFGX.EQ.1)GOTO 3671
  346.     CALL RECALC
  347.     IPSET=0
  348.     KKMAX=KKMAX-1
  349. C IMPLEMENT VARY LOOP...
  350. C ASSUME USRFCT MUSTR CONTOL KALKIT VARIABLE THEN TO GET LOOP TO
  351. C TERMINATE SOMETIME.
  352.     KKMAX=MIN0(KKMAX,KALKIT)
  353.     IF(KKMAX.GT.0)GOTO 3670
  354. 3671    CONTINUE
  355. C    IF(ICODE.NE.1.AND.RCFGX.NE.1)CALL RECALC
  356. C
  357. C DISPLAY SHEET NOW. ONLY ALTERS ENTRIES INVALIDATED BY COMMAND.
  358.     IF(ICODE.NE.2.AND.ICODE.NE.6)GOTO 21
  359. C ICODE=2 = REFRESH DISPLAY. ZERO ALL NUMBERS AND CAUSE TOTAL REDISPLAY.
  360.     DO 22 N1=1,20
  361.     DO 22 N2=1,75
  362. C SET NUMBER DISPLAYED TO WEIRD VALUE.
  363. 22    DVS(N1,N2)=DVS(N1,N2)+.000000000034
  364.     IF(PZAP.EQ.0)CALL UVT100(11,2,0)
  365.     CALL UVT100(1,1,1)
  366. 21    CONTINUE
  367.     IF(ICODE.EQ.6)ICODE=2
  368.     IF(ICODE.NE.5.AND.PZAP.EQ.0)CALL DSPSHT(ICODE)
  369.     DCOL=IDCL
  370.     DROW=IDRW
  371.     PROW=IPRSS
  372.     PCOL=IPCSS
  373.     GOTO 1000
  374. 5600    CONTINUE
  375. C ERROR ON READ FROM IOLVL HANDLED HERE.
  376. c    REWIND 5
  377.     CLOSE(11)
  378.     OPEN(11,FILE='CON:50/150/300/40/Analy Command',STATUS='OLD',
  379.      1  FORM='FORMATTED')
  380.     CLOSE(3)
  381.     IOLVL=11
  382.     GOTO 1000
  383.     END
  384. c -h- assign.for    Fri Aug 22 12:56:01 1986    
  385.     SUBROUTINE ASSIGN(IUNIT,NAME)
  386. C
  387. C
  388.     CHARACTER*1 NAME(50)
  389.     InTeGer*4 IUNIT
  390. C &&&& MS FTN 3.2
  391.     LOGICAL LEXIST
  392. C &&&&
  393.     CHARACTER*20 WK
  394.     CHARACTER*1 WK1(20)
  395.     EQUIVALENCE(WK(1:1),WK1(1))
  396. C JUST TRY AND NULL FILL A NAME TO USE.
  397.     DO 1 N=1,20
  398.     WK1(N)=' '
  399. 1    CONTINUE
  400.     DO 2 N=1,20
  401.     II=ICHAR(NAME(N))
  402.     IF(II.LT.32)GOTO 3
  403.     WK1(N)=CHAR(II)
  404. C1    CONTINUE
  405. 2    CONTINUE
  406. 3    CONTINUE
  407. C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
  408. C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
  409. C AVOID CRASHES IF THE FILE ISN'T THERE...
  410. C MSDOS FORTRAN 3.2 AND LATER FEATURE...
  411. C &&&&
  412. C
  413. C    INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
  414. C
  415.     INQUIRE(FILE=WK,EXIST=LEXIST)
  416.     IF(LEXIST)GOTO 100
  417. C FILE DOES NOT EXIST, SO CREATE IT HERE.
  418. C IF CREATE FAILS WE LOSE TOO...
  419.     CALL UVT100(1,1,1)
  420.     CALL SWRT('File not found. Attempting to create.',37)
  421.     OPEN(IUNIT,FILE=WK,STATUS='NEW',ACCESS='SEQUENTIAL',
  422.      1  FORM='FORMATTED')
  423.     CLOSE(IUNIT)
  424. C OPENS AND CLOSES FILE, CREATING A NULL FILE TO READ.
  425. C WILL GET EOF ON START, BUT THAT'S TOO BAD...
  426. 100    CONTINUE
  427. C &&&&
  428. C IF JUST CALL ASSIGN, ASSUME FOR READ.
  429.     OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
  430.      1  FORM='FORMATTED')
  431. 77    CONTINUE
  432. C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
  433. C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
  434.     RETURN
  435.     END
  436. c -h- at.for    Fri Aug 22 12:56:23 1986    
  437.     SUBROUTINE AT (RETCD)
  438. C COPYRIGHT (C) 1983 GLENN EVERHART
  439. C ALL RIGHTS RESERVED
  440. C 60=MAX REAL ROWS
  441. C 301=MAX REAL COLS
  442. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  443. C VBLS AND TYPE DIMENSIONED 60,301
  444. C *******************************************************
  445. C *                                                     *
  446. C *           SUBROUTINE  AT                            *
  447. C *                                                     *
  448. C *******************************************************
  449. C SUBROUTINE AT IS CALLED WHEN THE  *@  CALC COMMAND IS ENCOUNTERED.
  450. C IT CHANGES  THE  VALUE  OF LEVEL  WHICH  HOLDS THE  NUMBER OF THE
  451. C LOGICAL  I/O  UNIT WHERE INPUT COMMAND LINES ARE TO BE OBTAINED.
  452. C THE FILE ASSOCIATED WITH THAT I/O UNIT IS OPENED UNDER THE PROPER
  453. C CONDITIONS.
  454. C
  455. C MODIFICATION CLASSES: M1,M2,M9
  456. C
  457. C      MODIFIED 3-OCT-77 P.B.
  458. C      MODIFIED 10-JAN-78 P.B.  TO PUT SY: BEFORE FILENAMES
  459. C         WITH NO DEVICE SPECIFIED SO THAT DEFAULT IS USER'S SY:
  460. C         AND NOT THE SYSTEM SY:
  461. C
  462. C
  463. C    AT CALLS
  464. C
  465. C  ASSIGN  (TO ASSOCIATE A FILE NAME WITH A LOGICAL I/O UNIT)
  466. C  ERRMSG  (TO PRINT ERROR MESSAGES)
  467. C  GETNNB  (TO GET NEXT NON-BLANK FROM THE INPUT LINE)
  468. C  ZNEG    (TO TEST IF A VARIABLE IS POSITIVE)
  469. C
  470. C
  471. C
  472. C   AT IS CALLED BY ROUTINE CMND WHICH IS THE MODULE THAT DETERMINES
  473. C   WHAT CALC COMMAND WAS REQUESTED.
  474. C
  475. C
  476. C
  477. C         VARIABLE          USE
  478. C
  479. C   ALPHA(27)         HOLDS LEGAL VARIABLE NAMES.
  480. C   I,J               HOLD TEMPORARY VALUES.
  481. C   IPT               POINTS TO NEXT NON-BLANK CHARACTER IN LINE(80).
  482. C   ITCNTV(6)         INDEXED BY LEVEL. HOLDS 0 IF NO ITERATION ON THAT
  483. C                     LEVEL, OTHERWISE INDEX INTO VBLS FOR THE VARIABLE
  484. C                     THAT CONTROLS ITERATION.
  485. C   LEVEL             HOLDS NUMBER OF LOGICAL I/O UNIT WHERE NEXT INPUT
  486. C                     LINE IS EXPECTED.
  487. C   LINE(80)          HOLDS COMMAND INPUT LINE.
  488. C   NBLINE(78)        HOLDS THE INPUT FILE NAME WITHOUT BLANKS.
  489. C   NONBLK            POINTS TO THE LAST NON-BLANK CHARACTER IN LINE(80).
  490. C   RETCD             RETURN CODE: 1=O.K.  2=ERROR.
  491. C   SY                "SY:" USED TO OPEN FILES WITH A DEFAULT OF
  492. C                     USER'S SY: (OTHERWISE SYSTEM SY: IS USED) P.B.
  493. C                     10-JAN-78
  494. C
  495. C
  496. C
  497. C    SUBROUTINE AT (RETCD)
  498. C
  499.     InTeGer*4 IPT,J,I
  500.     InTeGer*4 LEVEL,NONBLK,LEND
  501.     InTeGer*4 RETCD,VIEWSW,BASED
  502.     InTeGer*4 ITCNTV(6),ZNEG
  503. C
  504.     CHARACTER*1  LINE(80),NBLINE(78)
  505.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  506. C    CHARACTER*1 SY(3)
  507. C
  508. C
  509.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  510.     COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  511.     COMMON/ITERA/ITCNTV
  512. C
  513. C    DATA SY/'S','Y',':'/
  514. C
  515. C
  516. C
  517. C UPON ENTRANCE, NONBLK POINTS TO THE CHARACTER @
  518. C
  519. C  MODIFICATION CLASSES:  M1,M2,M9
  520. C
  521. C PICK UP FIRST NON-BLANK AFTER THE @
  522.     CALL GETNNB(IPT,RETCD)
  523.     GO TO (10,1050),RETCD
  524.     STOP 10
  525. C
  526. C
  527. C START BUILDING FILE NAME AS A COMPRESSED VERSION (BLANKS REMOVED)
  528. C OF THE REST OF LINE(80)
  529. 10    J=0
  530. 15    NONBLK=IPT
  531.     J=J+1
  532.     NBLINE(J)=LINE(NONBLK)
  533.     CALL GETNNB(IPT,RETCD)
  534.     GO TO (15,50),RETCD
  535.     STOP 50
  536. C
  537. C
  538. C SET RETURN CODE AND INDICATE THAT WE WILL BE AT A NEW LEVEL.
  539. C J HOLDS THE COUNT OF THE NUMBER OF CHARACTERS IN NBLINE.
  540. C IF J=1 THEN NO ITERATION IS POSSIBLE BECAUSE FILENAME IS THE
  541. C SINGLE CHARACTER.
  542. 50    RETCD=1
  543.     LEVEL=LEVEL+1
  544.     IF (LEVEL.GT.6) GOTO 1000
  545. C
  546.     IF(J.EQ.1) GO TO 200
  547. C
  548. C NBLINE HOLDS THE COMPRESSED FILENAME. NOW WE CHECK TO SEE IF AN
  549. C ITERATION VARIABLE WAS SPECIFIED. THIS IS INDICATED BY A LEGAL
  550. C VARIABLE NAME PRECEEDED BY A BLANK (IN LINE(80))
  551. C NOTE THAT ONLY ONE OF THE ACCUMULATORS A-Z MAY BE USED FOR THIS.
  552.     DO 60 I=1,27
  553. C A-Z OR % LEGAL
  554.     IF(ALPHA(I).EQ.LINE(NONBLK))GO TO 100
  555. 60    CONTINUE
  556.     GO TO 200
  557. 100    IF(LINE(NONBLK-1).NE.BLANK)GO TO 200
  558. C
  559. C
  560. C ITERATION INDICATOR IS PRESENT
  561. C (ALPHABETIC CHARACTER OR % PRECEEDED BY A BLANK)
  562. C IF THE VALUE OF THE VARIABLE IS NOT POSITIVE, THE FILE IS IGNORED.
  563.     IF(ZNEG(I).EQ.1)GO TO 150
  564. C
  565. C
  566. C RETAIN INDEX INTO VBLS AND DECREASE J SO THAT THE FILENAME
  567. C DOES NOT INCLUDE THE ITERATION SPECIFICATION.
  568.     ITCNTV(LEVEL)=I
  569.     J=J-1
  570.     GO TO 300
  571. C
  572. C
  573. C FILE NOT ENTERED, ITERATION VARIABLE IS ZERO, NEGATIVE, OR UNDEFINED
  574. 150    LEVEL=LEVEL-1
  575.     GO TO 350
  576. C
  577. C
  578. C IF NO ITERATION, SET ITCNTV TO ZERO BECAUSE NOT ZEROED BY EXIT
  579. C ROUTINES
  580. 200    ITCNTV(LEVEL)=0
  581. 300    CONTINUE
  582.     NBLINE(J+1)=0
  583. C    OPEN(UNIT=LEVEL,NAME=NBLINE)
  584. C    CALL RASSIG (LEVEL,NBLINE,J)
  585.     CALL RASSIG (LEVEL,NBLINE)
  586. 350    RETURN
  587. C
  588. C *** ERROR PROCESSING ***
  589. C
  590. C  TOO MANY LEVELS
  591. 1000    I=2
  592. 1010    CALL ERRMSG(I)
  593. 1020    RETCD=2
  594.     RETURN
  595. C
  596. C
  597. C UNIDENTIFIED COMMAND (ARGUMENT)
  598. 1050    I=3
  599.     GO TO 1010
  600.     END
  601. c -h- bascng.for    Fri Aug 22 12:57:23 1986    
  602.     SUBROUTINE BASCNG(RETCD)
  603. C COPYRIGHT (C) 1983 GLENN EVERHART
  604. C ALL RIGHTS RESERVED
  605. C 60=MAX REAL ROWS
  606. C 301=MAX REAL COLS
  607. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  608. C VBLS AND TYPE DIMENSIONED 60,301
  609. C
  610. C SUBROUTINE BASCNG IS CALLED WHEN THE *B CALC COMMAND IS
  611. C ENCOUNTERED. THIS COMMAND INDICATES THAT THE DEFAULT BASE
  612. C FOR CONSTANTS IS TO BE CHANGED. THE ROUTINE READS IN ONE
  613. C OR TWO DIGITS AND CHANGES THE DEFAULT BASE SPECIFICATION
  614. C AS IS APPROPRIATE.
  615. C
  616. C MODIFICATION CLASS M2
  617. C
  618. C   BASCNG CALLS
  619. C
  620. C  ERRMSG  (PRINTS ERROR MESSAGES)
  621. C  GETNNB  (GETS THE NEXT NON-BLANK IN INPUT LINE LINE(80))
  622. C
  623. C
  624. C  BASCNG IS CALLED BY ROUTINE CMND WHICH IDENTIFIES THE COMMAND THAT
  625. C  THE USER WANTS TO EXECUTE.
  626. C
  627. C
  628. C    VARIABLE       USE
  629. C
  630. C    BASED       HOLDS THE DEFAULT BASE.
  631. C    IPT         POINTS TO THE NEXT NON-BLANK IN LINE(80).
  632. C    I1          BINARY VALUE OF FIRST DIGIT, VALUE OF NEW BASE.
  633. C    I2          BINARY VALUE OF SECOND DIGIT.
  634. C    NONBLK      POINTS TO THE LAST NON-BLANK IN LINE(80)
  635. C    RETCD       RETURN CODE: 1=O.K.  2=ERROR.
  636. C    RETCD2      HOLDS RETURN CODE FROM CALL TO GETNNB
  637. C
  638. C
  639. C
  640. C
  641. C    SUBROUTINE BASCNG(RETCD)
  642. C
  643. C
  644. C UPON ENTRANCE, NONBLK POINTS TO THE 'B' IN '*B' IN LINE
  645. C
  646.     InTeGer*4 IPT,I1,I2
  647.     InTeGer*4 LEVEL,NONBLK,LEND
  648.     InTeGer*4 RETCD,RETCD2,VIEWSW,BASED
  649. C
  650.     CHARACTER*1 DIGITS(16,3),LINE(80)
  651. C
  652.     COMMON /DIGV/ DIGITS
  653.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  654. C
  655. C
  656. C IF NO ARGUMENT, RETURN WITH NORMAL RETURN CODE. THIS ALLOWS THE
  657. C USER TO SEE WHAT THE PRESENT DEFAULT BASE IS.
  658.     RETCD=1
  659.     CALL GETNNB(IPT,RETCD2)
  660.     IF(RETCD2.GT.1)GO TO 1000
  661. C
  662. C
  663. C CHECK OUT FIRST DIGIT
  664.     DO 300 I1=1,10
  665.     IF(DIGITS(I1,1).EQ.LINE(IPT)) GO TO 400
  666. 300    CONTINUE
  667.     GO TO 999
  668. C
  669. C
  670. C SEE IF THERE IS A SECOND DIGIT
  671. 400    NONBLK=IPT
  672.     IF(I1.EQ.10)I1=0
  673.     CALL GETNNB(IPT,RETCD2)
  674.     IF(RETCD2.EQ.1)GO TO 500
  675. C
  676. C
  677. C IF NOT, CONVERT TO A TWO DIGIT NUMBER WITH A LEADING ZERO.
  678.     I2=I1
  679.     I1=0
  680.     GO TO 700
  681. C
  682. C A SECOND CHARACTER WAS FOUND; FIGURE OUT WHAT THE BINARY
  683. C VALUE IS (IF IT IS A DIGIT AT ALL).
  684. 500    DO 600 I2=1,10
  685.     IF(DIGITS(I2,1).EQ.LINE(IPT))GO TO 700
  686. 600    CONTINUE
  687.     GO TO 999
  688. C
  689. C CONVERT DIGITS TO A NUMBER IF IT IS LEGAL
  690. 700    IF(I2.EQ.10)I2=0
  691.     I1=I1*10+I2
  692.     IF(I1.NE.8.AND.I1.NE.10.AND.I1.NE.16) GO TO 999
  693.     BASED=I1
  694.     GO TO 1000
  695. C
  696. C
  697. C ILLEGAL BASE SPECIFICATION
  698. 999    RETCD=2
  699.     WRITE(11,998)
  700. 998    FORMAT(' Illegal Base. (Only 8,10,and 16 OK). Ignored.')
  701. C    CALL ERRMSG(19)
  702. C
  703. C RETURN
  704. 1000    RETURN
  705.     END
  706. c -h- blkdat.for    Fri Aug 22 12:57:49 1986    
  707.     BLOCK DATA
  708. C COPYRIGHT 1983 GLENN C.EVERHART
  709. C ALL RIGHTS RESERVED
  710. C    InTeGer*4 MFID(2),MFMOD(2)
  711.     InTeGer*2 IFID(8,2048)
  712.     COMMON/IFIDC/IFID
  713.     CHARACTER*1 LFID(16,2048)
  714.     EQUIVALENCE(IFID(1,1),LFID(1,1))
  715. C    COMMON/FRM/MFID,MFMOD
  716.     CHARACTER*1 DTBL1(9,9,8)
  717. C BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
  718.     InTeGer*2 BTBL(6,6,8)
  719. C REUSE SPACE BY MAKING LFID AND IT OVERLAY EACH OTHER.
  720. C NO NEED TO WASTE IT.
  721. c    INTEGER DTBLIN
  722. C DTBLIN FLAGS THAT DTBL1 WAS ALREADY INITED, SO ONLY DOES SO ONCE.
  723.     EQUIVALENCE(LFID(1,1),BTBL(1,1,1))
  724.     InTeGer*2 BTBL1(6,6)
  725.     InTeGer*2 BTBL2(6,6),BTBL3(6,6),BTBL4(6,6),BTBL5(6,6)
  726.     InTeGer*2 BTBL6(6,6),BTBL7(6,6),BTBL8(6,6)
  727.     EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
  728.     EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
  729.     EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
  730.     EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
  731.     COMMON /DECIDE/ DTBL1
  732. cc    DATA DTBLIN/0/
  733.     DATA BTBL1 /4,2,3,4,8,9,
  734.      1  6*0,0,2,0,0,0,9,0,2,0,0,0,9,
  735.      2  0,2,3,0,0,9,0,2,4*0/
  736.     DATA BTBL2/
  737.      3  4,5*0,2,0,3*2,0,3,3*0,2*0,4,3*0,2*0,
  738.      4  8,5*0,9,0,3*9,0/
  739.     DATA BTBL3/4,2,3,4,8,9,
  740.      5  6*2,3,2,3,3,3,9,4,2,3,4,4,9,
  741.      6  8,2,3,4,8,9,9,2,4*9/
  742.     DATA BTBL4/
  743.      7  4,2,3,4,8,9,6*2,3,2,3,3,3,9,4,2,3,4,4,9,
  744.      8  8,2,3,4,8,9,
  745.      9  9,2,4*9/
  746.     DATA BTBL5/4,2,3,3*4,6*0,6*0,6*0,
  747.      1  6*0,6*0/
  748.     DATA BTBL6/4,3*0,4,0,4,3*0,0,0,4,3*0,2*0,4,3*0,2*0,
  749.      2  4,3*0,2*0,
  750.      3  4,3*0,2*0/
  751.         DATA BTBL7/4,2,3,3*4,6*2,6*3,6*4,
  752.      4  6*8,6*9/
  753.     DATA BTBL8/4,1,4,4,4,3,2,1,2,2,2,1,4,3,4,4,
  754.      5  4,3,4,3,4,4,4,3,4,3,4,4,
  755.      6  4,3,2,1,2,2,2,1/
  756.     END
  757. c -h- ca2e.for    Fri Aug 22 13:00:17 1986    
  758.     SUBROUTINE CA2E(LNIN,LNOUT)
  759. C CONVERT NORMAL ASCII FORM TO ENCODED
  760.     CHARACTER*1 NAME(4),NUMBER(6)
  761.     CHARACTER*1 LNIN,LNOUT
  762.     CHARACTER*6 NUMBR6
  763.     EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
  764.     DIMENSION LNIN(128),LNOUT(128)
  765.     InTeGer*4 RRWACT,RCLACT
  766. C    COMMON/RCLACT/RRWACT,RCLACT
  767.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  768.      1  IDOL7,IDOL8
  769. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  770. C     1  IDOL7,IDOL8
  771.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  772. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  773.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  774. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  775. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  776. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  777.     InTeGer*4 KLVL
  778. C    COMMON/KLVL/KLVL
  779.     InTeGer*4 IOLVL,IGOLD
  780. C    COMMON/IOLVL/IOLVL
  781. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  782. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  783.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  784.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  785.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  786. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  787. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  788. C    LOGICAL*2 L63,L192,L255,L128
  789.     LOGICAL*4 L1,L2
  790. C    InTeGer*4 I63,I192,I255,I128
  791.     InTeGer*4 I63,I192,I127
  792.     InTeGer*4 I1,I2
  793. C    EQUIVALENCE(L128,I128)
  794. C    EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
  795.     EQUIVALENCE (I1,L1),(I2,L2)
  796. C    DATA I63/63/,I192/192/,I255/255/,I128/128/
  797.     DATA I63/63/,I192/192/,I127/127/
  798.     LI=1
  799.     LO=1
  800. C LI = INPUT LOCATION
  801. C LO=OUTPUT LOCATION
  802. 100    CONTINUE
  803.     LCC=ICHAR(LNIN(LI))
  804.     IF(LCC.EQ.255)GOTO 500
  805. C IF BINARY FORM, COPY 3 BYTES TO AVOID ERRORS.
  806.     IF(LCC.LT.65.OR.LCC.GT.89)GOTO 200
  807. C WE MUST ENSURE VARSCN ALWAYS SEES AN ALPHA AT START.
  808.     IL1=LI
  809.     LE=110
  810.     LSTC=LE
  811.     CALL VARSCN(LNIN,IL1,LE,LSTC,ID1,ID2,IVLD)
  812. C AVOID MESSING UP FUNCTION NAMES
  813.     IF(ID2.EQ.1)IVLD=0
  814.     IF(IDOL1.NE.0.OR.IDOL2.NE.0)IVLD=0
  815. C ONLY REPACK NORMAL FORM NAMES
  816. C NOTE THAT SINCE THESE HAVE $ AFTER THE FIELDS, NO PARTIAL NAME
  817. C WILL EVER GET RECOGNIZED WITHOUT IDOL1 OR IDOL2 GETTING SET.
  818.     IF(IVLD.EQ.0)GOTO 200
  819. C ALIASED NAMES MIGHT GET SCANNED WITHIN PRIME AREA IF THE FIRST
  820. C ONE OR TWO CHARS GET STRIPPED OFF, SO TREAT LIKE P## OR D## FORMS
  821. C AND COPY THE WHOLE NAME HERE.
  822.     IF(ID1.GT.60.OR.ID2.GT.301)GOTO 250
  823. C ALSO DON'T PACK ALIASED NAMES; THEY WON'T FIT IN CODED VALUES.
  824. C FOUND VARIABLE.
  825. C FIRST DON'T PACK P## AND D## FORMS.
  826.     IF(LNIN(LI+1).EQ.'#')GOTO 250
  827. C REPACK NORMAL VARIABLE HERE.
  828.     LI=LSTC
  829.     LNOUT(LO)=CHAR(255)
  830.     I1=IMASK(ID1,I63)
  831. C    I1=ID1
  832. C    L1=L1.AND.L63
  833.     I2=ID2/2
  834.     I2=IMASK(I2,I192)
  835. C    L2=L2.AND.L192
  836. C    L1=L1.OR.L2
  837.     I1=I1+I2
  838.     LNOUT(LO+1)=CHAR(I1)
  839. C    I2=ID2
  840.     I2=IMASK(ID2,I127)+128
  841. C    L2=L2.AND.L255
  842. C    L2=L2.OR.L128
  843.     LNOUT(LO+2)=CHAR(I2)
  844.     LO=MIN0(109,LO+3)    
  845.     GOTO 300
  846. 250    CONTINUE
  847. C JUST COPY DISPLAY FORMS.
  848.     IL1=LSTC-1
  849.     DO 251 N=LI,IL1
  850.     LNOUT(LO)=LNIN(N)
  851.     LO=LO+1
  852.     IF(LO.GT.110)GOTO 300
  853. 251    CONTINUE
  854.     LI=LSTC
  855. C THIS SKIPS OVER THE VARIABLE FOUND, SO WE GO ON.
  856.     GOTO 300
  857. 200    CONTINUE
  858. C HERE CHECK FOR FORMULA...
  859. C NOTE THAT SOME NAMES (E.G. "AVG" COULD CONFLICT WITH VERY LARGE COLUMN
  860. C NAMES. HOWEVER, IGNORE THAT POSSIBILITY. THAT'S AWFULLY FAR OUT.
  861.     CALL FNAME(LNIN(LI),II,INDX)
  862.     IF(INDX.LE.0.OR.INDX.GT.25)GOTO 220
  863. C Ensure that functions with indices too large to encode are
  864. C just treated literally. 229+25=254, the largest index we can have
  865. C before colliding with the 255 used to encode variable names.
  866. C thus all function names past the 25th must just be literally
  867. C entered. This is not really a problem as logic to find them
  868. C will work in either encoded or unencoded cases.
  869. C BE SURE A [ CHAR FOLLOWS NAME FOR THIS TO BE ACCEPTED...
  870.     IF(LNIN(LI+3).NE.'[')GOTO 220
  871. C FOUND MULTI-INPUT FUNCT NAME
  872.     LNOUT(LO)=CHAR(229+INDX)
  873. C SIMPLE 1-BYTE ENCODE OF NEEDED FUNCT NAME. NOT IN ANY CRITICAL RANGES...
  874.     LO=LO+1
  875.     LI=LI+3
  876.     GOTO 300
  877. 220    CONTINUE
  878.     LNOUT(LO)=LNIN(LI)
  879. C JUST COPY MISC. CHARACTER.
  880.     LO=LO+1
  881.     LI=LI+1
  882. 300    IF(LO.LT.109.AND.LI.LT.109)GOTO 100
  883. C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
  884.     LO=MIN0(LO,110)
  885.     DO 400 N=LO,110
  886. 400    LNOUT(N)=0
  887. C COPY REST OF 128 BYTE ARRAY
  888.     DO 1 N=111,128
  889. 1    LNOUT(N)=LNIN(N)
  890. C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
  891.     RETURN
  892. 500    CONTINUE
  893. C SPECIAL COPY OF 3 BYTE PACKED FORMS FOR SPEED
  894.     LNOUT(LO)=LNIN(LI)
  895.     LNOUT(LO+1)=LNIN(LI+1)
  896.     LNOUT(LO+2)=LNIN(LI+2)
  897.     LO=LO+3
  898.     LI=LI+3
  899.     GOTO 300
  900.     END
  901. c -h- calbin.for    Fri Aug 22 13:00:17 1986    
  902.     SUBROUTINE CALBIN(RETCD)
  903. C COPYRIGHT (C) 1983,1984 GLENN EVERHART
  904. C ALL RIGHTS RESERVED
  905. C 60=MAX REAL ROWS
  906. C 301=MAX REAL COLS
  907. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  908. C VBLS AND TYPE DIMENSIONED 60,301
  909. C
  910. C *******************************************************
  911. C *                                                     *
  912. C *             SUBROUTINE  CALBIN                      *
  913. C *                                                     *
  914. C *******************************************************
  915. C
  916. C  SUBROUTINE CALBIN PERFORMS A BINARY OPERATION ON TWO CONSTANTS.
  917. C
  918. C special version with multiple precision diked out - gce (to save space
  919. C on 256K PC)
  920. C  UPON ENTRANCE TO ROUTINE:
  921. C    OPERAND1 IS IN STACK1  (ST1PT-1)
  922. C    OPERAND2 IS ON TOP OF STACK2  (ST2PT-1)
  923. C    OPERATOR IS BELOW OPERAND2  (ST2PT-2)
  924. C  UPON EXIT:
  925. C    RESULT IS IN STACK1
  926. C    STACK2 HAS BEEN CLEANED UP
  927. C
  928. C  RETURN CODE    MEANING
  929. C    1    NORMAL RETURN
  930. C    2    OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
  931. C    3    ERROR RETURN
  932. C
  933. C
  934. C
  935. C  MODIFICATION CLASSES: M3, M4, AND M8
  936. C
  937. C
  938. C
  939. C  CALBIN CALLS
  940. C
  941. C  CONTYP   CONVERTS CONSTANTS TO DIFFERENT DATA TYPES
  942. C  ERRMSG   PRINTS OUT ERROR MESSAGES
  943. C  MULADD   PERFORMS MULTIPLE PRECISION ADDITION
  944. C  MULDIV   PERFORMS MULTIPLE PRECISION DIVISION
  945. C  MULMUL   PERFORMS MULTIPLE PRECISION MULTIPLICATION
  946. C
  947. C
  948. C
  949. C CALBIN IS CALLED BY POSTVL WHICH EVALUATES A POSTFIX EXPRESSION
  950. C
  951. C
  952. C
  953. C
  954. C   VARIABLE     USE
  955. C
  956. C  EIGHT(8)      PICKS OUT A REAL CONSTANT FROM STACK.
  957. C  FOUR(4)       PICKS OUT AN INTEGER CONSTANT FROM STACK.
  958. C  I,J           HOLD TEMPORARY VALUES.
  959. C  IA            FIRST BYTE OF OPERAND 1. THIS HOLDS THE INDEX INTO
  960. C                VBLS OF A VARIABLE IF THE OPERATOR IS AN = SIGN.
  961. C  ID            USED TO CONVERT DECISION TABLE CHARACTER*1 VALUE TO
  962. C                AN InTeGer*4 VALUE THAT CAN BE USED AS AN ARGUMENT
  963. C                IN A CALL TO CONTYP.
  964. C  INT,IHOLD     HOLD INTEGER*4 VALUES.
  965. C  IOP           HOLDS THE BINARY OPERATOR.
  966. C  IOP2          USED TO INDEX A COMPUTED GO.
  967. C  ISW           HOLDS BASE FOR MULTIPLE PRECISION EXPONENTIATION
  968. C  MINUS         VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
  969. C                NUMBER THAT IS USED TO INDICATE A NEGATIVE.
  970. C  OP1TYP        TYPE OF OPERAND 1.
  971. C  OP2TYP        TYPE OF OPERAND 2.
  972. C  PLUS          VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
  973. C                NUMBER THAT IS USED TO INDICATE POSITIVE.
  974. C  PT1,PT2       POINT TO ELEMENTS ON TOP OF STACKS 1 AND 2.
  975. C  REAL,RHOLD    HOLD TEMPORARY REAL*8 VALUES.
  976. C  RETCD         ERROR RETURN:  1 = O.K.   2 = RESULT WAS OUTPUT
  977. C                3 = ERROR
  978. C
  979. C
  980. C    SUBROUTINE CALBIN(RETCD)
  981.     REAL*8 REAL,RHOLD,DFLOAT
  982. C
  983.     INTEGER*4 INT,IHOLD
  984. C
  985.     InTeGer*4 LEVEL,NONBLK,LEND
  986.     InTeGer*4 VLEN(9)
  987.     InTeGer*4 IOP,IA,ID,IOP2,ISW
  988.     InTeGer*4 PLUS,MINUS
  989.     InTeGer*4 OLDTYP,VIEWSW,BASED
  990.     InTeGer*4 TYPE(1,1)
  991.     InTeGer*4 RETCD,RETCD2
  992.     InTeGer*4 OP1TYP,OP2TYP
  993.     InTeGer*4 ST1PT,ST2PT,ST1TYP(40),ST2TYP(40),ST1LIM,ST2LIM
  994.     InTeGer*4 PT1,PT2
  995. C
  996.     CHARACTER*1 STACK1(8,40),STACK2(8,40)
  997.     InTeGer*4 STK12(2,40)
  998.     REAL*8 XVBLK
  999.     EQUIVALENCE(STK12(1,1),STACK1(1,1))
  1000.     CHARACTER*1 AVBLS(20,27), DTBL1(9,9,8)
  1001.     CHARACTER*1 VBLS(8,1,1)
  1002.     EQUIVALENCE (XVBLK,VBLS(1,1,1))
  1003.     CHARACTER*1 EIGHT(8),FOUR(4)
  1004.     CHARACTER*1 LINE(80)
  1005. C
  1006.     EQUIVALENCE (EIGHT,REAL), (FOUR,INT)
  1007. C
  1008.     COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  1009.     COMMON/V/ TYPE,AVBLS,VBLS,VLEN
  1010.     COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
  1011.      ;         ST1LIM,ST2LIM
  1012.     COMMON /DECIDE/DTBL1
  1013. C
  1014. C
  1015.     DATA PLUS/0/,MINUS/1/
  1016. C
  1017. C
  1018.     RETCD=1
  1019.     PT1=ST1PT-1
  1020.     PT2=ST2PT-1
  1021. C
  1022.     IOP=ST2TYP(ST2PT-2)
  1023.     OP1TYP=ST1TYP(PT1)
  1024.     OP2TYP=ST2TYP(PT2)
  1025. C NOTE THAT IA IS UNUSED HERE... SAVE BIG DIMENSIONS
  1026.     IA=ICHAR(STACK1(1,PT1))
  1027.     ID1=STK12(1,PT1)
  1028.     ID2=STK12(2,PT1)
  1029. C    CALL GETDM(STACK1(1,PT1),ID1,ID2)
  1030. C ****&&&& ABOVE GETS LOCS IN 2 DIM ARRAY OF VARIABLES
  1031.     IF (IOP.NE.200) GOTO 100
  1032. C
  1033. C
  1034. C
  1035. C AN = SIGN IS THE OPERATOR. THIS IS A SPECIAL CASE.
  1036.     IF(OP1TYP.GE.0) GO TO 5
  1037. C
  1038. C
  1039. C
  1040. C VARIABLE TO THE LEFT OF = SIGN HAS A DATA TYPE BUT NO VALUE
  1041.     OP1TYP=-OP1TYP
  1042.     ST1TYP(PT1)=OP1TYP
  1043. C
  1044. C
  1045. C
  1046. C OPERAND 2 COPIED INTO OLD OPERAND'S POSITION IN CASE MORE
  1047. C THAN 1 = SIGN IS PRESENT FOR EXPRESSIONS LIKE  I=J=2
  1048. 5    J=VLEN(OP2TYP)
  1049. C    TYPE(IA)=OP1TYP
  1050.     CALL TYPSET(ID1,ID2,OP1TYP)
  1051. C    TYPE(ID1,ID2)=OP1TYP
  1052. C *&*****&&&&& NOTE TYPE ARRAY AND VBLS ARRAY NOW ARE HUGE
  1053. C  NOTE FURTHER THAT AVBLS IS OLD VBLS ARRAY. SWITCHED ON IF
  1054. C ID1 =< 27 AND ID2=1.
  1055.     DO 10 I=1,J
  1056. 10    STACK1(I,PT1)=STACK2(I,PT2)
  1057.     CALL CONTYP (STACK1,PT1,OP2TYP,OP1TYP,RETCD2)
  1058.     GOTO (20,9999), RETCD2
  1059.     STOP 20
  1060. C
  1061. C
  1062. C THE SPECIFIED VARIABLE GETS NEW VALUE.
  1063. C ***&&&& HERE'S WHERE WE STORE A VALUE INTO A VARIABLE...
  1064. 20    J=VLEN(OP1TYP)
  1065.     DO 30 I=1,J
  1066. C    VBLS(I,IA)=STACK1(I,PT1)
  1067.     IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 22
  1068. C REPLACE VBLSET CALL WITH XVBLST CALL ON LAST PASS TO AVOID
  1069. C MULTIPLE REPLACEMENT OF STORAGE FOR EVERY PASS.
  1070.     VBLS(I,1,1)=STACK1(I,PT1)
  1071.     IF(I.EQ.J)CALL XVBLST(ID1,ID2,XVBLK)
  1072. C    CALL VBLSET(I,ID1,ID2,STACK1(I,PT1))
  1073. C    VBLS(I,ID1,ID2)=STACK1(I,PT1)
  1074.     GOTO 30
  1075. 22    AVBLS(I,ID1)=STACK1(I,PT1)
  1076. C *****&&&&&
  1077. 30    CONTINUE
  1078.     GOTO 10000
  1079. C
  1080. C
  1081. C  IOP2 VALUES 1="**"  2="*"   3="/"   4="+"   5="-"
  1082. 100    IOP2=IOP-111
  1083.     GOTO (1000,2000,2000,2000,2000),IOP2
  1084. C
  1085. C
  1086. C    ********************************************
  1087. C    ***********  EXPONENTIATION  ***************
  1088. C    ********************************************
  1089. C
  1090. C
  1091. C  FIRST CONVERT TO PROPER TYPE
  1092. 1000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,5))
  1093.     CALL CONTYP(STACK1,PT1,OP1TYP,ID,RETCD2)
  1094.     IF (RETCD2.EQ.2) GOTO 9999
  1095.     ID=ICHAR(DTBL1(OP2TYP,OP1TYP,6))
  1096.     CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
  1097.     IF (RETCD2.EQ.2) GOTO 9999
  1098. C
  1099. C
  1100. C  GOTO APPROPRIATE PLACE TO PERFORM OPERATION
  1101.     ID=ICHAR(DTBL1(OP2TYP,OP1TYP,8))
  1102.     GOTO (1100,1200,1300,1400,1500,1600,1700),ID
  1103.     STOP 1000
  1104. C
  1105. C
  1106. C  REAL**REAL
  1107. 1100    DO 1104 I=1,8
  1108. 1104    EIGHT(I)=STACK1(I,PT1)
  1109.     RHOLD=REAL
  1110.     DO 1108 I=1,8
  1111. 1108    EIGHT(I)=STACK2(I,PT2)
  1112.     REAL=RHOLD**REAL
  1113. C
  1114. C
  1115. C  USED BY REAL**I
  1116. 1109    DO 1110 I=1,8
  1117. 1110    STACK1(I,PT1)=EIGHT(I)
  1118. C
  1119. C
  1120. C  USED BY I**REAL,I**I
  1121. 1114    ST1TYP(PT1)=ICHAR(DTBL1(OP2TYP,OP1TYP,7))
  1122.     GOTO 10000
  1123. C
  1124. C
  1125. C
  1126. C  REAL**I
  1127. 1200    DO 1204 I=1,8
  1128. 1204    EIGHT(I)=STACK1(I,PT1)
  1129.     DO 1208 I=1,4
  1130. 1208    FOUR(I)=STACK2(I,PT2)
  1131.     REAL=REAL**INT
  1132.     GOTO 1109
  1133. C
  1134. C
  1135. C
  1136. C  I**REAL (PARTS USED BY I**I)
  1137. 1300    DO 1304 I=1,4
  1138. 1304    FOUR(I)=STACK1(I,PT1)
  1139.     DO 1308 I=1,8
  1140. 1308    EIGHT(I)=STACK2(I,PT2)
  1141. C
  1142. C DIFFERENT VERSIONS OF FORTRAN TREAT THE RESULT IN DIFFERENT WAYS.
  1143. C IF YOU WANT THE RESULT TO BE REAL, YOU MUST ALSO CHANGE DTBL1.
  1144. C
  1145.     INT=DFLOAT(INT)**REAL
  1146. 1310    DO 1314 I=1,4
  1147. 1314    STACK1(I,PT1)=FOUR(I)
  1148.     GOTO 1114
  1149. C
  1150. C
  1151. C
  1152. C  I**I
  1153. 1400    DO 1404 I=1,4
  1154. 1404    FOUR(I)=STACK1(I,PT1)
  1155.     IHOLD=INT
  1156.     DO 1408 I=1,4
  1157. 1408    FOUR(I)=STACK2(I,PT2)
  1158.     INT=IHOLD**INT
  1159.     GOTO 1310
  1160. C
  1161. C
  1162. C
  1163. C  M8**I    (PARTS USED BY M10**I, M16**I)
  1164. 1500    ISW=8
  1165. 1501    IF(ST2PT.LE.ST2LIM)GO TO 1502
  1166. C
  1167. C
  1168. C STACK OVERFLOW
  1169.     CALL ERRMSG(9)
  1170.     GO TO 9999
  1171. C
  1172. C
  1173. C GET EXPONENT AS AN INTEGER
  1174. 1502    DO 1504 I=1,4
  1175. 1504    FOUR(I)=STACK2(I,PT2)
  1176.     IF (INT.GE.0) GOTO 1520
  1177. C
  1178. C
  1179. C EXPONENT NOT POSITIVE OR 0
  1180.     CALL ERRMSG (15)
  1181.     GOTO 9999
  1182. 1520    IF (INT.GT.0) GOTO 1530
  1183. C
  1184. C
  1185. C I**0 = 1
  1186.     STACK1(8,PT1)=PLUS
  1187.     DO 1522 I=2,7
  1188. 1522    STACK1(I,PT1)=0
  1189. C LEAVE AS INTEGER SETS HERE RATHER THAN EXPLICIT CHAR() CALLS
  1190.     STACK1(1,PT1)=1
  1191.     GOTO 10000
  1192. C
  1193. C
  1194. C EXPONENT IS > 0
  1195. 1530    INT=INT-1
  1196. C
  1197. C
  1198. C IF EXPONENT = 1 WE ARE DONE
  1199.     IF(INT.EQ.0)GO TO 10000
  1200. C
  1201. C
  1202. C EXPONENT IS > 1. COPY TO STACK 2 WHERE MULMUL EXPECTS THE OTHER
  1203. C FACTOR.
  1204.     DO 1534 I=1,8
  1205. 1534    STACK2(I,ST2PT)=STACK1(I,PT1)
  1206.     ST2TYP(ST2PT)=ST1TYP(PT1)
  1207. C
  1208. C
  1209. C
  1210. C
  1211. 1549    continue
  1212. c1549    DO 1550 I=1,INT
  1213. c    CALL MULMUL(PT1,ST2PT,RETCD2,ISW)
  1214. c    IF(RETCD2.GE.2)GO TO 9999
  1215. c1550    CONTINUE
  1216.     GOTO 10000
  1217. C
  1218. C  M10**I
  1219. 1600    ISW=10
  1220.     GOTO 1501
  1221. C
  1222. C
  1223. C
  1224. C  M16**I
  1225. 1700    ISW=16
  1226.     GOTO 1501
  1227. C
  1228. C
  1229. C  *****************************************
  1230. C  * MAKE CONVERSIONS APPROPRIATE FOR */+- *
  1231. C  *****************************************
  1232. 2000    CONTINUE
  1233.     ID=ICHAR(DTBL1(OP2TYP,OP1TYP,1))
  1234.     CALL CONTYP (STACK1,PT1,OP1TYP,ID,RETCD2)
  1235.     IF (RETCD2.EQ.2) GOTO 9999
  1236.     IF(ID.EQ.0)GO TO 2010
  1237.     ST1TYP(PT1)=ID
  1238.     OP1TYP=ID
  1239. 2010    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,2))
  1240.     CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
  1241.     IF (RETCD2.EQ.2) GOTO 9999
  1242.     IF(ID.EQ.0)GOTO 2020
  1243.     ST2TYP(PT2)=ID
  1244.     OP2TYP=ID
  1245. C
  1246. 2020    CONTINUE
  1247. C
  1248. C
  1249. C  GOTO SECTION ACCORDING TO OPERATION *=3000, /=4000,+=5000,-=6000
  1250.     GOTO (2100,3000,4000,5000,6000),IOP2
  1251. 2100    STOP 2100
  1252. C
  1253. C
  1254. C
  1255. C
  1256. C
  1257. C
  1258. C  **********************************************
  1259. C  ***********  MULTIPLICATION  *****************
  1260. C  **********************************************
  1261. 3000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1262.     GOTO (3100,3200,3300,3300,3500,3600,3700,3300,3200),ID
  1263.     STOP 3000
  1264. C
  1265. C
  1266. C  ASCII (ALSO SUBTRACTION, MULTIPLICATION AND DIVISION)
  1267. 3100    CALL ERRMSG (12)
  1268.     GOTO 9999
  1269. C
  1270. C
  1271. C  DECIMAL, REAL
  1272. 3200    DO 3204 I=1,8
  1273. 3204    EIGHT(I)=STACK1(I,PT1)
  1274.     RHOLD=REAL
  1275.     DO 3208 I=1,8
  1276. 3208    EIGHT(I)=STACK2(I,PT2)
  1277.     REAL=RHOLD*REAL
  1278. 3209    DO 3210 I=1,8
  1279. 3210    STACK1(I,PT1)=EIGHT(I)
  1280. C
  1281. C
  1282. C  FOLLOWING USED BY OTHER SECTIONS
  1283. 3220    ST1TYP(PT1)=ICHAR(DTBL1(OP2TYP,OP1TYP,3))
  1284.     GOTO 10000
  1285. C
  1286. C
  1287. C
  1288. C  HEX,INTEGER,OCTAL
  1289. 3300    DO 3304 I=1,4
  1290. 3304    FOUR(I)=STACK1(I,PT1)
  1291.     IHOLD=INT
  1292.     DO 3308 I=1,4
  1293. 3308    FOUR(I)=STACK2(I,PT2)
  1294.     INT=IHOLD*INT
  1295. 3309    DO 3310 I=1,4
  1296. 3310    STACK1(I,PT1)=FOUR(I)
  1297.     GOTO 3220
  1298. C
  1299. C
  1300. C
  1301. C  M10
  1302. 3500    continue
  1303. c3500    CALL MULMUL (PT1,PT2,RETCD2,10)
  1304. C
  1305. C
  1306. C  FOLLOWING USED BY OTHER SECTIONS
  1307. 3510    IF (RETCD2.EQ.2) GOTO 9999
  1308.     GOTO 3220
  1309. C
  1310. C
  1311. C
  1312. C  M8
  1313. 3600    continue
  1314. c3600    CALL MULMUL (PT1,PT2,RETCD2,8)
  1315.     GOTO 3510
  1316. C
  1317. C
  1318. C
  1319. C  M16
  1320. 3700    continue
  1321. c3700    CALL MULMUL (PT1,PT2,RETCD2,16)
  1322.     GOTO 3510
  1323. C
  1324. C
  1325. C  **************************************************
  1326. C  ******************  DIVISION  ********************
  1327. C  **************************************************
  1328. 4000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1329.     GOTO (3100,4200,4300,4300,4500,4600,4700,4300,4200),ID
  1330.     STOP 4000
  1331. C
  1332. C
  1333. C  DECIMAL,REAL
  1334. 4200    DO 4204 I=1,8
  1335. 4204    EIGHT(I)=STACK1(I,PT1)
  1336.     RHOLD=REAL
  1337.     DO 4208 I=1,8
  1338. 4208    EIGHT(I)=STACK2(I,PT2)
  1339.     IF(REAL.NE.0.D0)GO TO 4210
  1340.     CALL ERRMSG(23)
  1341.     GO TO 9999
  1342. 4210    REAL=RHOLD/REAL
  1343.     GOTO 3209
  1344. C
  1345. C
  1346. C  HEX,INTEGER,OCTAL
  1347. 4300    DO 4304 I=1,4
  1348. 4304    FOUR(I)=STACK1(I,PT1)
  1349.     IHOLD=INT
  1350.     DO 4308 I=1,4
  1351. 4308    FOUR(I)=STACK2(I,PT2)
  1352.     IF(INT.NE.0)GO TO 4310
  1353.     CALL ERRMSG(23)
  1354.     GO TO 9999
  1355. 4310    INT=IHOLD/INT
  1356.     GOTO 3309
  1357. C
  1358. C
  1359. C  M10
  1360. 4500    continue
  1361. c4500    CALL MULDIV (PT1,PT2,RETCD2,10)
  1362.     GOTO 3510
  1363. C
  1364. C
  1365. C  M8
  1366. 4600    continue
  1367. c4600    CALL MULDIV (PT1,PT2,RETCD2,8)
  1368.     GOTO 3510
  1369. C
  1370. C
  1371. C  M16
  1372. 4700    continue
  1373. c4700    CALL MULDIV (PT1,PT2,RETCD2,16)
  1374.     GOTO 3510
  1375. C
  1376. C
  1377. C
  1378. C
  1379. C
  1380. C **************************************************
  1381. C *****************  ADDITION  *********************
  1382. C **************************************************
  1383. C
  1384. 5000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1385.     GOTO (3100,5200,5300,5300,5500,5600,5700,5300,5200),ID
  1386.     STOP 5000
  1387. C
  1388. C
  1389. C  DECIMAL, REAL
  1390. 5200    DO 5204 I=1,8
  1391. 5204    EIGHT(I)=STACK1(I,PT1)
  1392.     RHOLD=REAL
  1393.     DO 5208 I=1,8
  1394. 5208    EIGHT(I)=STACK2(I,PT2)
  1395.     REAL=RHOLD+REAL
  1396.     GOTO 3209
  1397. C
  1398. C
  1399. C  HEX,INTEGER,OCTAL
  1400. 5300    DO 5304 I=1,4
  1401. 5304    FOUR(I)=STACK1(I,PT1)
  1402.     IHOLD=INT
  1403.     DO 5308 I=1,4
  1404. 5308    FOUR(I)=STACK2(I,PT2)
  1405.     INT=IHOLD+INT
  1406.     GOTO 3309
  1407. C
  1408. C
  1409. C  M10
  1410. 5500    continue
  1411. c5500    CALL MULADD (PT1,PT2,RETCD2,1)
  1412.     GOTO 3510
  1413. C
  1414. C
  1415. C  M8
  1416. 5600    continue
  1417. c5600    CALL MULADD (PT1,PT2,RETCD2,2)
  1418.     GOTO 3510
  1419. C
  1420. C
  1421. C  M16
  1422. 5700    continue
  1423. c5700    CALL MULADD(PT1,PT2,RETCD2,3)
  1424.     GOTO 3510
  1425. C
  1426. C
  1427. C
  1428. C
  1429. C
  1430. C
  1431. C  ***************************************************
  1432. C  ******************  SUBTRACTION  ******************
  1433. C  ***************************************************
  1434. C
  1435. 6000    ID=ICHAR(DTBL1(OP2TYP,OP1TYP,4))
  1436.     GOTO (3100,6200,6300,6300,6500,6600,6700,6300,6200),ID
  1437.     STOP 6000
  1438. C
  1439. C
  1440. C  DECIMAL,REAL
  1441. 6200    DO 6204 I=1,8
  1442. 6204    EIGHT(I)=STACK1(I,PT1)
  1443.     RHOLD=REAL
  1444.     DO 6208 I=1,8
  1445. 6208    EIGHT(I)=STACK2(I,PT2)
  1446.     REAL=RHOLD-REAL
  1447.     GOTO 3209
  1448. C
  1449. C
  1450. C  HEX,INTEGER,OCTAL
  1451. 6300    DO 6304 I=1,4
  1452. 6304    FOUR(I)=STACK1(I,PT1)
  1453.     IHOLD=INT
  1454.     DO 6308 I=1,4
  1455. 6308    FOUR(I)=STACK2(I,PT2)
  1456.     INT=IHOLD-INT
  1457.     GOTO 3309
  1458. C
  1459. C
  1460. C  M10
  1461. 6500    continue
  1462. c6500    CALL MULADD (PT1,PT2,RETCD2,4)
  1463.     GOTO 3510
  1464. C
  1465. C
  1466. C  M8
  1467. 6600    continue
  1468. c6600    CALL MULADD (PT1,PT2,RETCD2,5)
  1469.     GOTO 3510
  1470. C
  1471. C
  1472. C  M16
  1473. 6700    continue
  1474. c6700    CALL MULADD (PT1,PT2,RETCD2,6)
  1475.     GOTO 3510
  1476. C
  1477. C
  1478. C
  1479. C
  1480. C
  1481. C    EXIT
  1482. 9999    RETCD=3
  1483. C
  1484. C
  1485. C
  1486. 10000    ST2PT=ST2PT-2
  1487.     RETURN
  1488.     END
  1489. c -h- calc.for    Fri Aug 22 13:00:17 1986    
  1490.     SUBROUTINE CALC
  1491. C COPYRIGHT (C) 1983 GLENN EVERHART
  1492. C ALL RIGHTS RESERVED
  1493. C 60=MAX REAL ROWS
  1494. C 301=MAX REAL COLS
  1495. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  1496. C VBLS AND TYPE DIMENSIONED 60,301
  1497. C ***               CALC   MAINLINE                   ***
  1498. C
  1499. C THIS PROGRAM EVALUATES ARITHMETIC EXPRESSIONS INPUT TO IT
  1500. C AND ALLOWS VARIABLES TO BE ASSIGNED VALUES. IT FEATURES
  1501. C MULTIPLE PRECISION ARITHMETIC IN BASE 10, OCTAL, AND
  1502. C HEXADECIMAL. SEE CALC.MEM FOR A COMPLETE DESCRIPTION IN
  1503. C THE FORM OF A USERS GUIDE. TYPE ? TO OBTAIN A LIST OF
  1504. C POSSIBLE COMMANDS.
  1505. C
  1506. C    CALC CALLS
  1507. C
  1508. C  ASSIGN    OPENS A FILE AND ASSIGNS IT TO A LOGICAL I/O UNIT.
  1509. C  CLOSE     CLOSES A FILE ASSOCIATED WITH A LOGICAL I/O UNIT.
  1510. C  CMND      DETERMINES WHAT CALC COMMAND IS REQUIRED.
  1511. C  ERRCX     CHECKS THE EXPRESSION IN AN INPUT LINE FOR SYNTAX ERRORS.
  1512. C  ERRMSG    PRINTS OUT ERROR MESSAGES.
  1513. C  EXIT      RETURNS TO OPERATING SYSTEM.
  1514. C  GETMCR    GETS THE COMMAND LINE USED TO INVOKE CALC. IF AN ARGUMENT
  1515. C            IS PRESENT, CALC EXITS AFTER THAT ONE COMMAND IS EXECUTED.
  1516. C  INPOST    CONVERTS AN INFIX EXPRESSION TO POSTFIX FORM.
  1517. C  LIST      LISTS THE LEGAL CALC COMMANDS.
  1518. C  POSTVL    CONVERTS AN EXPRESSION IN POSTFIX NOTATION ON STACK 1 TO
  1519. C            A VALUE.
  1520. C  SLEND     FINDS THE LAST NON-BLANK IN LINE(80).
  1521. C  VAROUT    PRINTS OUT THE VALUE OF A VARIABLE.
  1522. C  ZNEG      DETERMINES IF A VARIABLE IS POSITIVE IN VALUE
  1523. C
  1524. C
  1525. C
  1526. C   VARIABLE      USE
  1527. C
  1528. C  BASED        DEFAULT BASE WHEN CONSTANTS ARE ENTERED.
  1529. C  BLANK        ' '
  1530. C  DIGITS(16,3) HOLDS DECIMAL, OCTAL, AND HEXADECIMAL DIGITS. THE
  1531. C               SECOND SUBSCRIPT IS
  1532. C                     1 FOR DECIMAL
  1533. C                     2 FOR OCTAL
  1534. C                     3 FOR HEXADECIMAL
  1535. C  I,J          HOLD TEMPORARY VALUES.
  1536. C  ITCNTV(6)    INDEXED BY LEVEL. 0 INDICATES THAT NO ITERATION ON THE
  1537. C               INDIRECT COMMAND FILE IS TO TAKE PLACE. IF POSITIVE, IT
  1538. C               HOLDS THE INDEX INTO VBLS AND REPRESENTS THE VARIABLE
  1539. C               USED TO CONTROL ITERATION.
  1540. C        THIS VARIABLE IS GUARANTEED TO BE 1-27.
  1541. C  LEND         POINTS TO LAST NON-BLANK CHARACTER IN LINE(80)
  1542. C  LEVEL        HOLDS THE LOGICAL I/O UNIT WHERE THE NEXT CALC COMMAND
  1543. C               LINES COME FROM.
  1544. C  LINE(80)     COMMAND INPUT LINE.
  1545. C  NONBLK       POINTS TO LAST NON-BLANK FOUND IN LINE(80).
  1546. C  ONCE         HOLDS 1 IF ONLY ONE COMMAND LINE IS TO BE EXECUTED,
  1547. C               0 OTHERWISE.
  1548. C  STAR         '*'
  1549. C  VIEWSW           VIEW SWITCH
  1550. C                    0 = OUTPUT ERROR MESSAGES
  1551. C                    1 = OUTPUT ERROR MESSAGES AND FILE COMMAND LINES
  1552. C                    2 = OUTPUT ERROR MESSAGES AND VALUE OF EXPRESSIONS
  1553. C                        EVALUATED.
  1554. C                    3 = OUTPUT EVERYTHING
  1555. C  WHAT         '?' SIGNIFIES THAT A LIST OF POSSIBLE COMMANDS
  1556. C               SHOULD BE OUTPUT.
  1557. C
  1558. C    MODIFIED    REASON
  1559. C
  1560. C    18-MAY-1981    DELETED LINE THAT CAUSED DEFAULT BASE TO BE RESET
  1561. C            WHEN AN ERROR OCCURS (PB)
  1562. C
  1563. C    18-MAY-1981    ADDED CODE AT LINES 106 TO 108 TO CONVERT FROM LOWER
  1564. C            TO UPPER CASE  (PB)
  1565. C
  1566. C CHANGED TO SUBROUTINE GCE TO ALLOW EXTERNAL CONTROL OF CALCULATOR.
  1567. C
  1568.     InTeGer*4 LEVEL,NONBLK,LEND
  1569.     InTeGer*4 RETCD,VIEWSW,BASED
  1570.     InTeGer*4 ONCE
  1571.     InTeGer*4 ZNEG,ITCNTV(6)
  1572. C
  1573.     CHARACTER*1  LINE(80),WHAT,STAR,QUOTE
  1574.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  1575.     CHARACTER*1 DIGITS(16,3)
  1576.     CHARACTER*1 OARRY(100)
  1577.     InTeGer*4 OSWIT,OCNTR
  1578. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  1579. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  1580.     InTeGer*4 IPS1,IPS2,MODFLG
  1581. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  1582.        InTeGer*4 XTCFG,IPSET,XTNCNT
  1583.        CHARACTER*1 XTNCMD(80)
  1584. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  1585. C VARY FLAG ITERATION COUNT
  1586.     INTEGER KALKIT
  1587. C    COMMON/VARYIT/KALKIT
  1588.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  1589.     InTeGer*4 RCMODE,IRCE1,IRCE2
  1590. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1591. C     1  IRCE2
  1592. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  1593. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  1594. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  1595. C RCFGX ON.
  1596. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  1597. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  1598. C  AND VM INHIBITS. (SETS TO 1).
  1599.     INTEGER*4 FH
  1600. C FILE HANDLE FOR CONSOLE I/O (RAW)
  1601. C    COMMON/CONSFH/FH
  1602.     CHARACTER*1 ARGSTR(52,4)
  1603. C    COMMON/ARGSTR/ARGSTR
  1604.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  1605.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  1606.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1607.      3  IRCE2,FH,ARGSTR
  1608.     InTeGer*4 ILNFG,ILNCT
  1609.     CHARACTER*1 ILINE(106)
  1610.     COMMON/ILN/ILNFG,ILNCT,ILINE
  1611. C
  1612.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  1613.     InTeGer*4 RRWACT,RCLACT
  1614. C    COMMON/RCLACT/RRWACT,RCLACT
  1615.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  1616.      1  IDOL7,IDOL8
  1617. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  1618. C     1  IDOL7,IDOL8
  1619.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  1620. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  1621.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  1622. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  1623. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  1624. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  1625.     InTeGer*4 KLVL
  1626. C    COMMON/KLVL/KLVL
  1627.     InTeGer*4 IOLVL,IGOLD
  1628. C    COMMON/IOLVL/IOLVL
  1629. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  1630. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  1631.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  1632.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  1633.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  1634. C    COMMON/KLVL/KLVL
  1635.     COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  1636.     COMMON /DIGV/ DIGITS
  1637.     COMMON/ITERA/ITCNTV
  1638. C
  1639.     DATA  WHAT/'?'/, STAR/'*'/, QUOTE/''''/
  1640.     DATA ONCE/0/
  1641. C
  1642. C
  1643. C
  1644. C LOGICAL I/O UNIT 1 IS ASSIGNED TO THE INVOKING TERMINAL
  1645. C IF YOU DON'T WANT TO RISK THE BUILDER TASK BUILDING (LINKING)
  1646. C THE MODULES PROPERLY, PUT IN A
  1647.     IF(KLVL.EQ.1)LEVEL=KLVL
  1648.     ONCE=0
  1649. C    IF(ILNFG.NE.0) GOTO 6000
  1650. C    CALL ASSIGN (1,'TT:')
  1651. 6000    CONTINUE
  1652. C CHANGE TI: TO TT: FOR VMS.
  1653. C
  1654.     IF(ILNFG.EQ.0)GOTO 6010
  1655.     IF(ILNCT.GT.0)GOTO 6010
  1656. C INVALID INPUTS...NO LINE TO DO BUT FLAGGED TO DO. CLEAN UP.
  1657.     ILNFG=0
  1658.     RETURN
  1659. 6010    CONTINUE
  1660.     IF(ILNFG.NE.0.AND.ILNCT.GT.0)GOTO 6001
  1661. C ++++++
  1662. C FOR DEC FORTRAN:
  1663. C    CALL GETMCR(LINE,LEND)
  1664. C    IF(LEND)20,20,5
  1665. C FOR NON-DEC FORTRAN: (OR VAX VERSIONS)
  1666.     GOTO 20
  1667. C ++++++  END OF CHOICES...
  1668. 5    CONTINUE
  1669.     GOTO 6003
  1670. 6001    CONTINUE
  1671.     DO 6007 LENDX=1,80
  1672. 6007    LINE(LENDX)=CHAR(32)
  1673.     IF(ILNFG.EQ.1)ONCE=1
  1674.     I255X=0
  1675.     DO 6002 LENDX=1,ILNCT
  1676.     LINE(LENDX)=ILINE(LENDX)
  1677.     IF(ICHAR(LINE(LENDX)).EQ.255)I255X=3
  1678.     IF(I255X.LE.0)GOTO 4602
  1679.     I255X=I255X-1
  1680.     GOTO 6002
  1681. C SKIP ENTIRE 3-CHR PACKED CODES
  1682. 4602    CONTINUE
  1683.     IF(ICHAR(LINE(LENDX)).GT.0.AND.ICHAR(LINE(LENDX)).LT.32)
  1684.      1  LINE(LENDX)=CHAR(32)
  1685. C LEAVE ANY EXISTING NULLS IN.
  1686. 6002    CONTINUE
  1687.     LEND=ILNCT
  1688. CD    CALL FRMEDT(LINE,LEND)
  1689. C FRMEDT IMPLEMENTS EDITS OF {VAR INTO THAT VARIABLE'S FORMULA
  1690. CC NULL TERMINATE THE LINE TO ENSURE WE END SOMEWHERE.
  1691. C    ICCC=MIN0(80,(LEND+1))
  1692. C    LINE(ICCC)=0
  1693.     GOTO 103
  1694. 6003    CONTINUE
  1695.     DO 6 NONBLK=1,7
  1696.     IF(LINE(NONBLK).EQ.BLANK)GO TO 7
  1697.     IF(ICHAR(LINE(NONBLK)).EQ.13)GO TO 20
  1698. 6    CONTINUE
  1699.     STOP 6
  1700. 7    NONBLK=NONBLK+1
  1701.     ONCE=1
  1702.     GO TO 106
  1703. C
  1704. C  ERROR RESET
  1705.  
  1706. 10    IF(LEVEL.LE.1) GO TO 12
  1707.     CLOSE(LEVEL)
  1708.     LEVEL=LEVEL-1
  1709.     GO TO 10
  1710. 12    CONTINUE
  1711.     VIEWSW=3
  1712. C
  1713. C
  1714. C  GET NEXT INPUT LINE
  1715. 20    CONTINUE
  1716.     LINE(1)=0
  1717.     LINE(2)=0
  1718.     IF(ONCE.EQ.1.AND.LEVEL.LE.1) RETURN
  1719. C20    IF(ONCE.EQ.1.AND.LEVEL.EQ.1) CALL EXIT
  1720. C    IF (ILNFG.NE.0.AND.ILNCT.GT.0)GOTO 6004
  1721.     IF (LEVEL.LE.1.AND.ILNFG.NE.0.AND.ILNCT.GT.0)RETURN
  1722.     IF(LEVEL.LT.1)RETURN
  1723.     IF(ILNFG.EQ.0.AND.LEVEL.EQ.1)WRITE(11,22)
  1724. 22    FORMAT(' CALC>')
  1725. C
  1726. C
  1727.     LLLV=LEVEL
  1728.     IF(LLLV.EQ.1)LLLV=11
  1729.     READ (LLLV,24,END=900,ERR=1000) LINE
  1730. 24    FORMAT (80A1)
  1731. C    GOTO 6005
  1732. C SECTION BELOW COMMENTED OUT BECAUSE IT SHOULD NEVER BE CALLED (GCE).
  1733. C6004    CONTINUE
  1734. C    DO 6006 LENDX=1,80
  1735. C6006    LINE(LENDX)=CHAR(32)
  1736. CC ABOVE BLANKS OUT LINE ARRAY
  1737. C    DO 6007 LENDX=1,ILNCT
  1738. C6007    LINE(LENDX)=ILINE(LENDX)
  1739. CC ABOVE COPIES INPUT FROM OUR CALLER...
  1740. C6005    CONTINUE
  1741. C
  1742. C
  1743. C
  1744. C FIND LAST NONBLANK, SAVE POSITION WITH VARIABLE 'LEND'
  1745. CD    CALL FRMEDT(LINE,LEND)
  1746.     CALL SLEND(RETCD)
  1747.     GO TO(30,20),RETCD
  1748.     STOP 30
  1749. 30    CONTINUE
  1750. C
  1751. C
  1752.     IF(ILNFG.EQ.0.AND.ILNCT.GT.0)GOTO 103
  1753. C SHOW WHAT WAS READ FROM FILE
  1754.     IF(LEVEL.NE.1.AND.(VIEWSW.EQ.1.OR.VIEWSW.EQ.3))
  1755.      1 WRITE(11,40)LEVEL,(LINE(I),I=1,LEND)
  1756. 40    FORMAT (' CALC<',I1,'>',80A1)
  1757. 103    CONTINUE
  1758. C NULL TERMINATE THE LINE TO ENSURE WE END SOMEWHERE.
  1759.     ICCC=MIN0(80,(LEND+1))
  1760.     LINE(ICCC)=0
  1761. C
  1762. C  IDENTIFY FIRST NON-BLANK
  1763.     DO 104 NONBLK=1,LEND
  1764.     IF (LINE(NONBLK).NE.BLANK) GOTO 106
  1765. 104    CONTINUE
  1766.     RETURN
  1767. C    STOP 104
  1768. C
  1769. C CONVERT LOWER CASE TO UPPER CASE
  1770. 106    CONTINUE
  1771.     I255X=0
  1772.     DO 108 I=NONBLK,LEND
  1773.     J=ICHAR(LINE(I))
  1774.     IF(J.EQ.255)I255X=3
  1775.     IF(I255X.LE.0)GOTO 3107
  1776. C SKIP ENCODED VARIABLE NAMES
  1777.     I255X=I255X-1
  1778.     GOTO 107
  1779. 3107    CONTINUE
  1780.     IF (I.EQ.NONBLK) GOTO 107
  1781.     IF (LINE(I-1).EQ.QUOTE) GOTO 108
  1782.     IF(J.GE.97.AND.J.LE.122) LINE(I)=CHAR(J-32)
  1783. 107    CONTINUE
  1784. 108    CONTINUE
  1785. C
  1786. C  SEE IF A LIST OF POSSIBLE COMMANDS SHOULD BE PRINTED
  1787.     IF (LINE(NONBLK).NE.WHAT) GOTO 110
  1788.     CALL LIST
  1789.     GOTO 20
  1790. C
  1791. C  SEE IF IT IS A COMMAND
  1792. 110    IF (LINE(NONBLK).NE.STAR) GOTO 120
  1793.     CALL CMND (RETCD)
  1794.     GOTO (20,115,10,6120), RETCD
  1795. 6120    RETURN
  1796. C    STOP 110
  1797. C
  1798. C
  1799. C A READ COMMAND WAS EXECUTED SO LINE HOLDS THE NEW COMMAND LINE.
  1800. 115    CALL SLEND(RETCD)
  1801.     GO TO (103,20),RETCD
  1802.     RETURN
  1803. C    STOP 115
  1804. C
  1805. C  SEE IF ONLY ONE ALPHA CHARACTER
  1806. 120    J=NONBLK+1
  1807.     IF (LEND.NE.NONBLK) GOTO 130
  1808.     DO 124 I=1,27
  1809.     IF (LINE(NONBLK).EQ.ALPHA(I)) GOTO 126
  1810. 124    CONTINUE
  1811. C
  1812. C ALLOW FOR A SINGLE DIGIT TO BE ASSIGNED TO %
  1813.     DO 125 I=1,10
  1814.     IF(LINE(NONBLK).EQ.DIGITS(I,1))GO TO 130
  1815. 125    CONTINUE
  1816. C
  1817. C
  1818. C ALLOW FOR ENTERING THE ASCII BLANK
  1819.     IF(LINE(NONBLK).EQ.QUOTE)GO TO 130
  1820.     I=1
  1821.     GOTO 1001
  1822. C
  1823. C  OUTPUT VALUE OF SINGLE VARIABLE
  1824. 126    CALL VAROUT(I,1)
  1825.     GOTO 20
  1826. C
  1827. C
  1828. C CHECK INPUT FOR SYNTAX ERRORS
  1829. 130    CALL ERRCX (RETCD)
  1830.     GOTO (140,10),RETCD
  1831.     RETURN
  1832. C    STOP 130
  1833. C
  1834. C  CHANGE FROM INFIX TO POSTFIX NOTATION
  1835. 140    CALL INPOST (RETCD)
  1836.     GOTO (150,10), RETCD
  1837. C
  1838. C
  1839. C EVALUATE EXPRESSION
  1840. 150    CONTINUE
  1841.     CALL POSTVL(RETCD)
  1842.     GOTO(20,10),RETCD
  1843.     RETURN
  1844. C    STOP 150
  1845. C
  1846. C
  1847. C  EXIT
  1848. 900    CONTINUE
  1849.     IF (LEVEL.EQ.1) RETURN
  1850. C    IF (LEVEL.EQ.1) CALL EXIT
  1851.     IF(ITCNTV(LEVEL).EQ.0)GOTO 910
  1852.     IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GO TO 910
  1853. C
  1854. C VALUE OF ITERATION VARIABLE IS POSITIVE SO REWIND FILE
  1855. C AND EXECUTE AGAIN.
  1856.     REWIND LEVEL
  1857.     GO TO 20
  1858. C
  1859. C
  1860. C EXIT FROM THIS LEVEL BY CLOSING THE FILE AND DECREASING VALUE
  1861. C OF LEVEL BY ONE.
  1862. 910    CLOSE(LEVEL)
  1863.     LEVEL=LEVEL-1
  1864.     GOTO 20
  1865. C
  1866. C
  1867. C
  1868. C *** ERROR PROCESSING ***
  1869. 1000    I=27
  1870. 1001    CALL ERRMSG(I)
  1871.     GO TO 10
  1872.     END
  1873. c -h- calun.for    Fri Aug 22 13:00:17 1986    
  1874.     SUBROUTINE CALUN(RETCD)
  1875. C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
  1876. C ALL RIGHTS RESERVED
  1877. C 60=MAX REAL ROWS
  1878. C 301=MAX REAL COLS
  1879. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  1880.  
  1881. C VBLS AND TYPE DIMENSIONED 60,301
  1882. C  *****************************************************
  1883. C  *             SUBROUTINE   CALUN                    *
  1884. C  *****************************************************
  1885. C
  1886. C  SUBROUTINE CALUN PERFORMS A UNARY OPERATION.
  1887. C
  1888. C  UPON ENTRANCE:
  1889. C    OPERATOR IS ON STACK 2
  1890. C    OPERAND IS ON STACK 1
  1891. C  UPON EXIT:
  1892. C    OPERATOR HAS BEEN POPPED OFF STACK 2
  1893. C    RESULT IS ON STACK 1
  1894. C
  1895. C    RETCD    MEANING
  1896. C
  1897. C    1    O.K.
  1898. C    2    ERROR
  1899. C
  1900. C   MODIFICATION CLASSES: M3, M4, AND M8
  1901. C
  1902. C  CALUN CALLS
  1903. C
  1904. C  CONTYP   CONVERTS DATA TYPES
  1905. C  ERRMSG   PRINTS ERROR MESSAGES
  1906. C  $DATAN   ARC TANGENT
  1907. C  $DCOS    COSINE
  1908. C  $DEXP    E**X
  1909. C  $DLOG    NATURAL LOG
  1910. C  $DLOG10  LOG BASE 10
  1911. C  $DSIN    SINE
  1912. C  $DSQRT   SQUARE ROOT
  1913. C  $DTANH   HYPERBOLIC TANGENT
  1914. C
  1915. C  CALUN IS CALLED BY POSTVL WHICH CONVERTS FROM INFIX TO POSTFIX
  1916. C
  1917. C     VARIABLE    USE
  1918. C
  1919. C  RETCD      RETURN CODE:  1 = O.K.   2 = ERROR
  1920. C  J,K,K2,I   HOLD TEMPORARY VALUES
  1921. C  MINUS      VALUE IN LAST MULTIPLE PRECISION BYTE.
  1922. C             USED TO INDICATE A NEGATIVE NUMBER.
  1923. C  PLUS       VALUE IN LAST MULTIPLE PRCISION BYTE.
  1924. C             USED TO INDICATE A POSITIVE NUMBER.
  1925. C  REAL       TEMPORARY DOUBLE PRECISION VALUES.
  1926. C  INT        TEMPORARY INTEGER*4 VALUES.
  1927. C  ST1TYP(40) TYPE FOR EACH ELEMENT ON STACK 1
  1928. C  ST2TYP(40) TYPE FOR EACH ELEMENT OF STACK 2
  1929. C  ST1PT      POINTS TO TOP OF STACK 1
  1930. C  ST2PT      POINTS TO TOP OF STACK 2
  1931. C  STACK1     HOLDS OPERAND
  1932. C  STACK2     HOLDS UNARY OPERATOR
  1933. C
  1934. C    SUBROUTINE CALUN(RETCD)
  1935.     REAL*8 REAL
  1936.     REAL*8 DABS,DEXP,DLOG,DLOG10,DSQRT,DSIN,DCOS
  1937.     REAL*8 DASIN,DACOS,DTAN
  1938.     REAL*8 DTANH,DATAN
  1939. C
  1940.     REAL*4 FLOAT
  1941. C
  1942.     INTEGER*4 INT
  1943. C
  1944.     InTeGer*4 RETCD,RETCD2
  1945.     InTeGer*4 ST1TYP(40),ST2TYP(40),ST1PT,ST2PT,ST1LIM,ST2LIM
  1946.     InTeGer*4 K,K2
  1947. C
  1948.     CHARACTER*1 STACK1(8,40),STACK2(8,40),FOUR(4),EIGHT(8)
  1949.     CHARACTER*1 PLUS,MINUS
  1950. C
  1951.     EQUIVALENCE (FOUR,INT),(EIGHT,REAL)
  1952. C
  1953.     COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,
  1954.      ;          ST1TYP,ST2TYP,ST1LIM,ST2LIM
  1955. C
  1956. C    DATA PLUS/0/,MINUS/1/
  1957. C
  1958.     PLUS=0
  1959.     MINUS=1
  1960.     RETCD=1
  1961.     K=ST2TYP(ST2PT-1)
  1962.     K2=ST1TYP(ST1PT-1)
  1963. C
  1964. C
  1965. C MAKE SURE VARIABLE IS DEFINED
  1966.     IF(K2.GT.0)GOTO 50
  1967. C IF NOT, PRINT MESSAGE AND RETURN
  1968.     CALL ERRMSG(16)
  1969.     GOTO 89999
  1970. C
  1971. 50    J=K
  1972. C
  1973. C
  1974. C SEE IF IT IS A UNARY MINUS
  1975.     IF (J.EQ.111) GOTO 100
  1976. C
  1977. C
  1978. C  FUNCTIONS START AT 31
  1979.     K=K-30
  1980.     GOTO (100,100,300,400,500,400,10000),K
  1981.     GOTO 10000
  1982. C
  1983. C
  1984. C  ***************************************
  1985. C  *** ABS (=DABS), IABS, AND UNARY -  ***
  1986. C  ***************************************
  1987. 100    CONTINUE
  1988.     IF(K2.GT.0)GO TO 105
  1989.     CALL ERRMSG(16)
  1990.     GO TO 89999
  1991. 105    GOTO (110,120,130,130,140,140,140,130,120),K2
  1992.     STOP 100
  1993. C
  1994. C
  1995. C  ASCII
  1996. 110    CALL ERRMSG (12)
  1997.     GOTO 89999
  1998. C
  1999. C
  2000. C  DECIMAL AND REAL
  2001. 120    DO 121 I=1,8
  2002. 121    EIGHT(I)=STACK1(I,ST1PT-1)
  2003.     IF (K.NE.111) GOTO 123
  2004. C
  2005. C
  2006. C  UNARY -
  2007.     REAL=-REAL
  2008.     GOTO 124
  2009. 123    REAL=DABS(REAL)
  2010. 124    DO 125 I=1,8
  2011. 125    STACK1(I,ST1PT-1)=EIGHT(I)
  2012.     GOTO 90000
  2013. C
  2014. C
  2015. C  INTEGER, HEXADECIMAL, AND OCTAL
  2016. 130    DO 131 I=1,4
  2017. 131    FOUR(I)=STACK1(I,ST1PT-1)
  2018.     IF (K.NE.111) GOTO 133
  2019.     INT=-INT
  2020.     GO TO 134
  2021. 133    IF(INT.LT.0)INT=-INT
  2022. 134    DO 135 I=1,4
  2023. 135    STACK1(I,ST1PT-1)=FOUR(I)
  2024.     GOTO 90000
  2025. C
  2026. C
  2027. C  MULTIPLE PRECISION
  2028. 140    IF (K.NE.111) GOTO 150
  2029.     IF (STACK1(8,ST1PT-1).EQ.PLUS)GOTO 160
  2030. 150    STACK1(8,ST1PT-1)=PLUS
  2031.     GOTO 90000
  2032. 160    STACK1(8,ST1PT-1)=MINUS
  2033.     GOTO 90000
  2034. C
  2035. C
  2036. C  ***************************************
  2037. C  ************  FLOAT  ******************
  2038. C  ***************************************
  2039. 300    CONTINUE
  2040.     GOTO (310,320,330,330,340,340,340,330,320),K2
  2041. C
  2042. C
  2043. C  ASCII
  2044. 310    CALL ERRMSG(12)
  2045.     GOTO 89999
  2046. C
  2047. C
  2048. C  REAL (=DECIMAL)
  2049. 320    CALL ERRMSG (13)
  2050.     GOTO 89999
  2051. C
  2052. C
  2053. C  INTEGER=HEXADECIMAL=OCTAL
  2054. 330    DO 333 I=1,4
  2055. 333    FOUR(I)=STACK1(I,ST1PT-1)
  2056.     REAL=FLOAT(INT)
  2057.     DO 335 I=1,8
  2058. 335    STACK1(I,ST1PT-1)=EIGHT(I)
  2059.     ST1TYP(ST1PT-1)=2
  2060.     GOTO 90000
  2061. C
  2062. C
  2063. C  MULTIPLE PRECISION
  2064. 340    CALL ERRMSG (11)
  2065.     GOTO 89999
  2066. C
  2067. C
  2068. C
  2069. C  ***************************************
  2070. C  *******  IFIX AND INT (=IDINT)  *******
  2071. C  ***************************************
  2072. 400    CONTINUE
  2073.     GOTO (410,420,430,430,440,440,440,430,420),K2
  2074.     STOP 400
  2075. C
  2076. C
  2077. C  ASCII
  2078. 410    CALL ERRMSG (12)
  2079.     GOTO 89999
  2080. C
  2081. C
  2082. C  REAL AND DECIMAL
  2083. 420    DO 421 I=1,8
  2084. 421    EIGHT(I)=STACK1(I,ST1PT-1)
  2085.     INT=IDINT(REAL)
  2086.     DO 424 I=1,4
  2087. 424    STACK1(I,ST1PT-1)=FOUR(I)
  2088.     ST1TYP(ST1PT-1)=4
  2089.     GOTO 90000
  2090. C
  2091. C
  2092. C  INTEGER, HEXADECIMAL, AND OCTAL
  2093. 430    CALL ERRMSG (10)
  2094.     GOTO 89999
  2095. C
  2096. C
  2097. C  MULTIPLE PRECISION
  2098. 440    CALL ERRMSG (11)
  2099.     GOTO 89999
  2100. C
  2101. C
  2102. C
  2103. C  ***************************************
  2104. C  ***************  AINT  ****************
  2105. C  ***************************************
  2106. C
  2107. C  REAL TO REAL TRUNCATION
  2108. 500    CONTINUE
  2109.     GOTO (510,520,530,530,540,540,540,530,520),K2
  2110. C
  2111. C
  2112. C  ASCII
  2113. 510    CALL ERRMSG (12)
  2114.     GOTO 89999
  2115. C
  2116. C
  2117. C  REAL AND DECIMAL
  2118. 520    DO 522 I=1,8
  2119. 522    EIGHT(I)=STACK1(I,ST1PT-1)
  2120. C
  2121. C DON'T USE AINT(SNGL(REAL)) BECAUSE THEN
  2122. C 2.9999999 RESULTS IN 3.0
  2123.     REAL=DINT(REAL)
  2124.     DO 524 I=1,8
  2125. 524    STACK1(I,ST1PT-1)=EIGHT(I)
  2126.     GOTO 90000
  2127. C
  2128. C
  2129. C  INTEGER, HEXADECIMAL, AND OCTAL
  2130. 530    CALL ERRMSG (10)
  2131.     GOTO 89999
  2132. C
  2133. C
  2134. C  MULTIPLE PRECISION
  2135. 540    CALL ERRMSG(11)
  2136.     GOTO 89999
  2137. C
  2138. C
  2139. C
  2140. C
  2141. C  ****************************************
  2142. C  ****************************************
  2143. C  ********                        ********
  2144. C  ******** REAL TO REAL FUNCTIONS ********
  2145. C  ********                        ********
  2146. C  ********  EXP      (=DEXP)      ********
  2147. C  ********  ALOG     (=DLOG)      ********
  2148. C  ********  ALOG10   (=DLOG10)    ********
  2149. C  ********  SQRT     (=DSQRT)     ********
  2150. C  ********  SIN      (=DSIN)      ********
  2151. C  ********  COS      (=DCOS)      ********
  2152. C  ********  TANH     (DTANH)      ********
  2153. C  ********  ATAN     (=DATAN)     ********
  2154. C  ********                        ********
  2155. C  ****************************************
  2156. C  ****************************************
  2157. C
  2158. C
  2159. C
  2160. 10000    CONTINUE
  2161.     GOTO (11000,12000,15000,15000,15000,15000,15000,15000,12000),K2
  2162.     STOP 10000
  2163. C
  2164. C
  2165. C  ASCII
  2166. 11000    CALL ERRMSG (12)
  2167.     GOTO 89999
  2168. C
  2169. C
  2170. C  REAL AND DECIMAL
  2171. 12000    DO 12010 I=1,8
  2172. 12010    EIGHT(I)=STACK1(I,ST1PT-1)
  2173.     K=K-6
  2174.     GOTO (12100,12200,12300,12400,12500,12600,12700,12800,
  2175.      1  12840,12860,12880),K
  2176. C
  2177. C
  2178. C  EXP
  2179. 12100    REAL=DEXP(REAL)
  2180.     GOTO 14000
  2181. C
  2182. C
  2183. C  ALOG
  2184. 12200    REAL=DLOG(REAL)
  2185.     GOTO 14000
  2186. C
  2187. C
  2188. C  DLOG10
  2189. 12300    REAL=DLOG10(REAL)
  2190.     GOTO 14000
  2191. C
  2192. C
  2193. C  DSQRT
  2194. 12400    IF (REAL.GE.0.D0) GOTO 12410
  2195. 12405    CALL ERRMSG (14)
  2196.     GOTO 89999
  2197. 12410    REAL=DSQRT (REAL)
  2198.     GOTO 14000
  2199. C
  2200. C
  2201. C  DSIN
  2202. 12500    REAL=DSIN(REAL)
  2203.     GOTO 14000
  2204. C
  2205. C
  2206. C  DCOS
  2207. 12600    REAL=DCOS(REAL)
  2208.     GOTO 14000
  2209. C
  2210. C
  2211. C  DTANH
  2212. 12700    REAL=DTANH(REAL)
  2213.     GOTO 14000
  2214. C
  2215. C
  2216. C  DATAN
  2217. 12800    REAL=DATAN(REAL)
  2218.     GOTO 14000
  2219. C
  2220. C ASIN
  2221. 12840    CONTINUE
  2222.     IF(REAL.LT. -1.0.OR.REAL.GT. 1.0) GOTO 12405
  2223.     REAL=DASIN(REAL)
  2224.     GOTO 14000
  2225. C
  2226. C ACOS
  2227. 12860    CONTINUE
  2228.     IF(REAL.LT. -1.0.OR.REAL.GT. 1.0) GOTO 12405
  2229.     REAL=DACOS(REAL)
  2230.     GOTO 14000
  2231. C
  2232. C TAN
  2233. 12880    CONTINUE
  2234.     IF(REAL.GT.1.570795)REAL=1.570795
  2235.     IF(REAL.LT. -1.570795) REAL = -1.570795
  2236. C CLAMP TO AVOID OVERFLOW
  2237.     REAL=DTAN(REAL)
  2238. C    GOTO 14000
  2239. C (GOTO NOT NEEDED IF THIS IS THE LAST FUNCTION)
  2240. 14000    DO 14010 I=1,8
  2241. 14010    STACK1(I,ST1PT-1)=EIGHT(I)
  2242.     GOTO 90000
  2243. C
  2244. C
  2245. C  INTEGER, HEXADECIMAL, OCTAL, AND MULTIPLE PRECISION
  2246. 15000    CONTINUE
  2247.     CALL CONTYP(STACK1,ST1PT-1,K2,2,RETCD2)
  2248.     GO TO(15010,89999),RETCD2
  2249.     STOP 15000
  2250. 15010    ST1TYP(ST1PT-1)=2
  2251.     GO TO 12000
  2252. C
  2253. C
  2254. C  EXIT
  2255. 89999    RETCD=2
  2256. 90000    ST2PT=ST2PT-1
  2257.     RETURN
  2258.     END
  2259. c -h- ce2a.fms    Fri Aug 22 13:00:17 1986    
  2260.     SUBROUTINE CE2A(LNIN,LNOUT)
  2261. C CONVERT ENCODED FORMULAS TO NORMAL ASCII
  2262. C NOTE: ONLY HAS TO HANDLE STANDARD NAMES AS A$5$ TYPE FORMS AND P# AND D# FORMS
  2263. C ARE NOT TRANSLATED TO PACKED ONES.
  2264.     CHARACTER*1 NAME(4),NUMBER(6)
  2265.     CHARACTER*1 LNIN,LNOUT
  2266.     CHARACTER*6 NUMBR6
  2267.     EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
  2268.     DIMENSION LNIN(128),LNOUT(128)
  2269. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  2270. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  2271.     InTeGer*4 RRWACT,RCLACT
  2272. C    COMMON/RCLACT/RRWACT,RCLACT
  2273.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2274.      1  IDOL7,IDOL8
  2275. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2276. C     1  IDOL7,IDOL8
  2277.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2278. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2279.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2280. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2281. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2282. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2283.     InTeGer*4 KLVL
  2284. C    COMMON/KLVL/KLVL
  2285.     InTeGer*4 IOLVL,IGOLD
  2286. C    COMMON/IOLVL/IOLVL
  2287. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2288. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2289.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2290.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2291.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2292. C    LOGICAL*2 L63,L192,L255,L127
  2293.     LOGICAL*4 L1,L2
  2294. C    InTeGer*4 I63,I192,I255,I127
  2295.     InTeGer*4 I63,I192,I127
  2296.     InTeGer*4 I1,I2
  2297. C    EQUIVALENCE(L127,I127)
  2298. C    EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
  2299.     EQUIVALENCE (I1,L1),(I2,L2)
  2300.     INTEGER*4 FNAM(25)
  2301.     character*4 fnmx(25)
  2302.     CHARACTER*1 FCHNM(4,25)
  2303.     equivalence(fnmx(1)(1:1),fnam(1),fchnm(1,1))
  2304. c    EQUIVALENCE(FNAM(1),FCHNM(1,1))
  2305.     DATA FNMX/'MIN ','MAX ','AVG ','SUM ','STD ','IF  ',
  2306.      1  'AND ','IOR ','NOT ','CNT ','NPV ','LKP ',
  2307.      2  'LKN ','LKE ','XOR ','EQV ','MOD ','REM ','SGN ','IRR ',
  2308.      3  'RND ','PMT','PVL','AVE','CHS'/
  2309. C    DATA I63/63/,I192/192/,I255/255/,I128/128/
  2310.     DATA I63/63/,I192/192/,I127/127/
  2311.     LI=1
  2312.     LO=1
  2313. C LI = INPUT LOCATION
  2314. C LO=OUTPUT LOCATION
  2315. 100    CONTINUE
  2316.     LCC=ICHAR(LNIN(LI))
  2317.     IF(LCC.NE.255)GOTO 200
  2318. C FIND BINARY PATTERNS TO USE
  2319.     I1=ICHAR(LNIN(LI+1))
  2320.     I2=IMASK(I1,I192)
  2321. C    L2=L1.AND.L192
  2322.     I1=IMASK(I1,I63)
  2323. C    L1=L1.AND.L63
  2324.     ID1=I1
  2325.     I1=ICHAR(LNIN(LI+2))
  2326.     I1=IMASK(I1,I127)
  2327. C    L1=L1.AND.L127
  2328.     ID2=I2*2+I1
  2329.     LI=MIN0(LI+3,109)
  2330. C DO MASKING TO GET BINARY COORDS
  2331.     CALL IN2AS(ID1,NAME)
  2332. C NAME GETS 4 CHARACTERS TO USE FOR COL. LABEL
  2333.     IL2=ID2-1
  2334.     WRITE(NUMBR6(1:6),1000)IL2
  2335. C    ENCODE(6,1000,NUMBER)IL2
  2336. 1000    FORMAT(I6)
  2337. C NOW NAME AND NUMBER ARRAYS HAVE LETTERS, DIGITS, OR SPACES.
  2338. C THROW OUT SPACES AND COPY THE REST.
  2339.     DO 202 N=1,4
  2340.     IF(ICHAR(NAME(N)).LE.32)GOTO 202
  2341.     LNOUT(LO)=NAME(N)
  2342.     LO=LO+1
  2343.     IF(LO.GT.110)GOTO 300
  2344. 202    CONTINUE
  2345.     DO 203 N=1,6
  2346.     IF(ICHAR(NUMBER(N)).LE.32)GOTO 203
  2347. C IF 32 ISN'T SPACE, LOSE
  2348.     LNOUT(LO)=NUMBER(N)
  2349.     LO=LO+1
  2350.     IF(LO.GT.110)GOTO 300
  2351. 203    CONTINUE
  2352.     GOTO 300
  2353. C COPY MISC. CHARACTER
  2354. 200    CONTINUE
  2355.     II=ICHAR(LNIN(LI))
  2356.     IF(II.LT.230.OR.II.GT.254)GOTO 220
  2357. C FUNCTION NAME...
  2358.     II=II-229
  2359.     LNOUT(LO)=FCHNM(1,II)
  2360.     LNOUT(LO+1)=FCHNM(2,II)
  2361.     LNOUT(LO+2)=FCHNM(3,II)
  2362.     LI=LI+1
  2363.     LO=LO+3
  2364. C FILL IN ASCII FORM OF FUNCTION HERE...
  2365.     GOTO 300
  2366. 220    CONTINUE
  2367.     LNOUT(LO)=LNIN(LI)
  2368.     LO=LO+1
  2369.     LI=LI+1
  2370. 300    IF(LO.LT.109.AND.LI.LT.109)GOTO 100
  2371. C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
  2372.     LO=MIN0(LO,110)
  2373.     DO 400 N=LO,110
  2374. 400    LNOUT(N)=0
  2375.     DO 1 N=111,128
  2376. 1    LNOUT(N)=LNIN(N)
  2377. C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
  2378.     RETURN
  2379.     END
  2380. c -h- cmdmun.for    Fri Aug 22 13:00:17 1986    
  2381.     SUBROUTINE CMDMUN(LINE)
  2382. C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
  2383. C ALL RIGHTS RESERVED
  2384. ccc
  2385. ccc junk VT100 escape sequence parsing except for arrow keys and
  2386. ccc PF2 since it's mostly not useful in MSDOS anyway.
  2387. ccc
  2388.     CHARACTER*1 LINE(120),LC,LINBUF(120)
  2389. C    InTeGer*4 IOLVL,IGOLD
  2390.     EXTERNAL INDX
  2391. C    COMMON/IOLVL/IOLVL,IGOLD
  2392.     InTeGer*4 RRWACT,RCLACT
  2393. C    COMMON/RCLACT/RRWACT,RCLACT
  2394.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2395.      1  IDOL7,IDOL8
  2396. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2397. C     1  IDOL7,IDOL8
  2398.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2399. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2400.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2401. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2402. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2403. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2404.     InTeGer*4 KLVL
  2405. C    COMMON/KLVL/KLVL
  2406.     InTeGer*4 IOLVL,IGOLD
  2407. C    COMMON/IOLVL/IOLVL
  2408. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2409. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2410.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2411.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2412.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2413. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2414. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2415.     ITERX=0
  2416. C ALLOW RESCAN OF READ-IN COMMANDS UP TO 10 TIMES.
  2417. 6501    CONTINUE
  2418.     ITERX=ITERX+1
  2419.     IF(ITERX.GT.10)RETURN
  2420.     LI=1
  2421. C ALLOW ARROWS OR OTHER SIMILAR KEYS TO BE RECOGNIZED
  2422.     LL=ICHAR(LINE(LI))
  2423. C ALLOW ! OR ESCAPE TO BE LEADIN FOR ESCAPE SEQUENCES
  2424.     IF(LL.EQ.33.OR.LL.EQ.27)GOTO 1000
  2425. C ALLOW % SPECIAL TREATMENT
  2426.     IF(ICHAR(LINE(1)).EQ.37)GOTO 7000
  2427.     IF(LINE(1).EQ.'^')IGOLD=IGOLD+1
  2428.     IF(LINE(1).EQ.'^')GOTO 7223
  2429. C IF WE SEE , COULB BE THAT ESC GOT EATEN BY VMS...
  2430.     IF(LINE(LI).EQ.'[')GOTO 1000
  2431. C CONVERT LOWER TO UPPER CASE
  2432.     NMX=120
  2433.     DO 41 N=1,120
  2434. C CHECK FOR DOUBLE QUOTE (34 DECIMAL). LEAVE L.C. IF SO
  2435.     NNN=ICHAR(LINE(N))
  2436.     IF(NNN.EQ.34)NMX=2
  2437. C IF WE SEE " CHARACTER THEN ONLY CONVERT 1ST 2 CHARACTERS TO U.C.
  2438. 41    CONTINUE
  2439.     JFED=0
  2440.     DO 1 N=1,NMX
  2441.     LL=ICHAR(LINE(N))
  2442.     IF(LL.GT.96.AND.LL.LT.123)LL=LL-32
  2443.     LINE(N)=CHAR(LL)
  2444.     IF(LINE(N).EQ.'_'.AND.LINE(N+1).EQ.'_')JFED=N
  2445. 1    CONTINUE
  2446.     IF(JFED.LE.0)GOTO 520
  2447. C IF __ SEEN (2 UNDERSCORES IN A ROW), CALL FRMEDT AFTER REMOVING THE __ FROM
  2448. C THE COMMAND LINE.
  2449.     DO 521 KKK=JFED,118
  2450.     LINE(KKK)=LINE(KKK+2)
  2451. 521    CONTINUE
  2452.     LINE(119)=Char(0)
  2453.     LINE(120)=Char(0)
  2454.     KKK=110
  2455.     CALL FRMEDT(LINE,KKK)
  2456. 520    CONTINUE
  2457.     IF(LINE(1).NE.'M')GOTO 2000
  2458. C    IF(LINE(1).NE.'M')RETURN
  2459.     LI=2
  2460.     GOTO 1000
  2461. 1000    CONTINUE
  2462. C HANDLE ESCAPE SEQUENCES
  2463. C ENCODE VT100 SEQUENCES HERE. MUST MODIFY FOR OTHERS.
  2464. C IF VMS PASSES 2 ESCS, PASS 1ST, TEST SECOND.
  2465. C NOTE CURSOR UP,DOWN, RIGHT, LEFT ARE CODED AS ESC A,B,C, OR D
  2466. C WITH POSSIBLE CRUFT BETW ESC AND THE LETTER.
  2467.     LL=ICHAR(LINE(LI+1))
  2468.     IF(LL.EQ.27)LI=LI+1
  2469.     LC=ICHAR(LINE(LI+1))
  2470.     IF(LC.EQ.'['.OR.LC.EQ.'O'.OR.LC.EQ.'?')LC=ICHAR(LINE(LI+2))
  2471.     IF(LC.NE.'Q')GOTO 10
  2472. C MAKE PF2 MEAN HELP, JUST LIKE EDT
  2473.     LINE(LI)=CHAR(72)
  2474. C 72 = ASCII FOR 'H'
  2475.     LGGG=IGOLD+8
  2476.     IF(IGOLD.LE.0)GOTO 488
  2477.     LINE(LI+1)=CHAR(LGGG/10)
  2478.     LINE(LI+2)=CHAR(MOD(LGGG,10))
  2479. 488    CONTINUE
  2480. C    RETURN
  2481.     GOTO 2000
  2482. 10    CONTINUE
  2483. C HANDLE AUX KEYPAD KEYS AS INDIRECTS (FOR NOW)
  2484. C MAP ENTER KEY INTO AUX KEYPAD RANGE
  2485.     IF(LC.EQ.'M')LC='o'
  2486.     IF(LC.GE.'l'.AND.LC.LE.'y')GOTO 2650
  2487.     IF(LC.GE.'P'.AND.LC.LE.'S')GOTO 2100
  2488. C HANDLE INDIRECT CALLS AT 2100 FOR PF1 THRU PF4 IF AANY
  2489.     LL=ICHAR(LC)
  2490.     LL=LL-65
  2491. C SUBTRACT ASCII A
  2492.     IF (LL.LT.0.OR.LL.GT.3)GOTO 2000
  2493.     LK=LL
  2494.     IF(LL.EQ.3)LK=2
  2495.     IF(LL.EQ.2)LK=3
  2496.     LK=LK+49
  2497. C ADJUST FOR ASCII VALUE
  2498.     LINE(LI)=CHAR(LK)
  2499. C STASH NEW CELL IN.
  2500. C DON'T DISTURB GOLD STATUS ON MOTION OR ON HELP. ONLY ON INDIRECT
  2501. C COMMAND FILES.
  2502.     RETURN
  2503. C    GOTO 2000
  2504. 2650    CONTINUE
  2505.     LL=ICHAR(LC)
  2506.     LL=LL-ICHAR('l')+ICHAR('A')
  2507. C MAPPING IS:
  2508. C  KEY    CHAR    AKx.CMD  x=
  2509. C  0    p    E
  2510. c  1    q    F
  2511. C  2    r    G
  2512. c  3    s    H
  2513. c  4    t       I
  2514. c  5    u    J
  2515. c  6    v    K
  2516. c  7    w    L
  2517. c  8    x    M
  2518. c  9    y    N
  2519. c  ,    l    A
  2520. c  -    m    B
  2521. c  .    n    C
  2522. c ENTER o    D
  2523.     LC=CHAR(LL)
  2524.     LINE(1)=CHAR(64)
  2525. C 64 IS ASCII @ CHARACTER
  2526.     IVL=0
  2527. C BUILD WITH /DEBUG OPTION TO INCLUDE "DK:" IN STRING
  2528. c for now, leave command files on default disk since ASSIGN command fails on
  2529. c Chameleon (and Ghod knows what else). This isn't really all that painful since
  2530. c we can encode the @file commands directly via ansi.sys if desired, and will
  2531. c most likely do so. This allows the logic to work for Rainbow and the like
  2532. c still.
  2533.     LINE(2)='D'
  2534.     LINE(3)='K'
  2535.     LINE(3)=':'
  2536.     IVL=2
  2537.     LINE(2+IVL)='A'
  2538.     LINE(3+IVL)='K'
  2539.     GOTO 2600
  2540. 2100    CONTINUE
  2541. C GENERATE INDIRECT FILE CALLS FROM PF1, PF3, PF4 KEYS IF ANY
  2542. C (THESE GIVE LETTERS P, R, OR S)
  2543.     LINE(1)=CHAR(64)
  2544.     IVL=0
  2545. C BUILD WITH /DEBUG OPTION TO INCLUDE "D:" IN STRING
  2546.     LINE(2)='D'
  2547.     LINE(3)='K'
  2548.     LINE(3)=':'
  2549.     IVL=2
  2550.     LINE(2+IVL)='K'
  2551.     LINE(3+IVL)='Y'
  2552. 2600    CONTINUE
  2553.     LINE(4+IVL)=LC
  2554.     IF(IGOLD.LE.0)GOTO 7202
  2555. C GOLD ADDS EXTRA A,B,C,D,E,... ETC. AFTER FILENAME
  2556.     LINE(5+IVL)=CHAR(64+IGOLD)
  2557.     IVL=IVL+1
  2558. C ADD EXTRA LETTER FOR GOLDED COMMANDS
  2559. 7202    CONTINUE
  2560.     LINE(5+IVL)='.'
  2561.     LINE(6+IVL)='C'
  2562.     LINE(7+IVL)='M'
  2563.     LINE(8+IVL)='D'
  2564.     LINE(9+IVL)=0
  2565. C GENERATE @KYP, @KYR, OR @KYS COMMAND ON PF1, PF3, PF4
  2566. 2000    CONTINUE
  2567.     IGOLD=0
  2568.     RETURN
  2569. 7000    CONTINUE
  2570. C PROCESS %%% FORMS
  2571.     I1=INDX(LINE(2),37)
  2572. C IF I1 IS 1, THEN WE JUST HAVE %% AND THERE'S NOTHING TO DUMP TO
  2573. C THE SCREEN. OTHERWISE DUMP IT OUT HERE..
  2574.     I1=I1+1
  2575.     IF(I1.LE.2.OR.I1.GT.80)GOTO 7002
  2576.     II1=I1-1
  2577.     IV=II1-1
  2578.     CALL SWRT(LINE(2),IV)
  2579. 7301    FORMAT(80A1,60A1)
  2580. 7002    CONTINUE
  2581.     IF(I1.GT.80)RETURN
  2582. C COPY WHATEVER NEEDS TO BE COPIED TO LINBUF
  2583.     DO 7003 II=1,80
  2584. 7003    LINBUF(II)=0
  2585.     I2=INDX(LINE(I1+1),37)
  2586.     IF(I2.GT.80)RETURN
  2587.     I2=I2+I1
  2588.     I1=I1+1
  2589.     II2=I2-1
  2590.     II=0
  2591.     IF(II2.LT.I1)GOTO 7540
  2592.     DO 7004 LL=I1,II2
  2593.     II=II+1
  2594. 7004    LINBUF(II)=LINE(LL)
  2595. 7540    CONTINUE
  2596.     IF(I2.GT.80)RETURN
  2597. C IF LINE(I2+1) HAS & THEN CLOSE FILE RIGHT HERE AND BUG OFF
  2598.     IF(LINE(I2+1).NE.'&')GOTO 8005
  2599.     CLOSE (IOLVL)
  2600.     IOLVL=11
  2601.     LINE(I2+1)='\'
  2602. 8005    CONTINUE
  2603. C SEE IF LINE(I2+1) CONTAINS A ?
  2604.     IF(LINE(I2+1).NE.'?'.AND.LINE(I2+1).NE.'\')GOTO 7005
  2605. C HAVE TO READ IN USER'S LINE HERE... READ OFF UNIT 5 ALWAYS...
  2606.     LX=II+1
  2607.     READ(11,7301,END=7035,ERR=7035)(LINBUF(II),II=LX,120)
  2608. c For AMIGA we use lun 11 for console, both input and output,
  2609. c for all commands except normal sheet operation (e.g. help etc.)
  2610. C NOW SEE IF LINBUF(LX) IS EITHER A \ CHAR OR ANY CONTROL CHARACTER
  2611.     LC=LINBUF(LX)
  2612.     IF(LINE(I2+1).EQ.'\'.OR.LINE(I2+1).EQ.'!')GOTO 7005
  2613.     IF(IOLVL.EQ.11)GOTO 7005
  2614. C IF WE SEE ANYTHING EXCEPT A CONTROL CHAR OR \, REWIND THE FILE...
  2615. C THIS ALLOWS US TO HAVE A SORT OF "ENTER MODE" AND A "COMMAND MODE"
  2616. C A LA SUPERCALC ETC.
  2617.     IF(LC.NE.'\'.AND.LC.GT.CHAR(32))REWIND IOLVL
  2618. C COMMENT OUT ANY TERMINAL COMMAND
  2619.     IF(LC.EQ.'\'.OR.LC.EQ.'!'.OR.LC.LE.CHAR(32))LINBUF(1)='*'
  2620.     GOTO 7005
  2621. 7035    CONTINUE
  2622. C RECOVER AFTER CTL-Z ON EXPECTED INPUT.
  2623. C    REWIND 5
  2624.     LINBUF(1)='*'
  2625.     CLOSE (IOLVL)
  2626.     IF(IOLVL.EQ.11)OPEN(11,FILE='CON:40/150/300/40/Analy Command')
  2627.     IOLVL=11
  2628. 7005    CONTINUE
  2629.     DO 7006 II=1,120
  2630. 7006    LINE(II)=LINBUF(II)
  2631.     GOTO 6501
  2632. C ALLOW RESCAN OF COMMAND LINE AFTER READ-IN.
  2633. C    RETURN
  2634. C RETURN AFTER BUMPING IGOLD. COMMENT OUT CMD
  2635. 7223    CONTINUE
  2636.     LINE(1)='*'
  2637.     RETURN
  2638.     END
  2639. c -h- cmnd.f40    Fri Aug 22 13:00:17 1986    
  2640.     SUBROUTINE CMND(RETCD)
  2641. C COPYRIGHT (C) 1983 GLENN EVERHART
  2642. C ALL RIGHTS RESERVED
  2643. C 60=MAX REAL ROWS
  2644. C 301=MAX REAL COLS
  2645. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  2646. C VBLS AND TYPE DIMENSIONED 60,301
  2647. C   ***************************************************
  2648. C   *                                                 *
  2649. C   *         SUBROUTINE  CMND                        *
  2650. C   *                                                 *
  2651. C   ***************************************************
  2652. C
  2653. C
  2654. C  UPON ENTRANCE, NONBLK POINT TO THE "*" IN LINE
  2655. C  INDICATING A COMMAND.  THIS ROUTINE DETERMINES WHICH COMMAND
  2656. C  IS DESIRED AND CALLS THE APPROPRIATE SUBROUTINE.
  2657. C
  2658. C  RETCD:
  2659. C  1=NORMAL
  2660. C  2=BYPASS NEXT READ BECAUSE READ COMMAND HAS BEEN EXECUTED
  2661. C     TO CHANGE LINE(80)
  2662. C  3=ERROR, SO GO TO 1000 TO SET LEVEL=1
  2663. C
  2664. C
  2665. C MODIFY CLASSES: M1
  2666. C
  2667.  
  2668. C
  2669. C   CMND CALLS
  2670. C
  2671. C  AT      TO PROCESS A FILE OF CALC COMMANDS
  2672. C  BASCNG  TO CHANGE THE DEFAULT BASE FOR CONSTANTS
  2673. C  CLOSE   CLOSE FILE OF CALC COMMANDS
  2674. C  DECLR   DECLARE VAIABLES TO BE A CERTAIN DATA TYPE
  2675. C  ERRMSG  PRINTS ERROR MESSAGES
  2676. C  EXIT    RETURN TO OPERATING SYSTEM
  2677. C  GETNNB  GETS NEXT NON-BLANK FROM LINE(80)
  2678. C  STRCMP  LOOKS FOR A SPECIFIED STRING IN LINE(80)
  2679. C  ZERO    ZEROES ALL VARIABLES
  2680. C  ZNEG    TO SEE IF A VARIABLE HAS POSITIVE VALUE
  2681. C
  2682. C
  2683. C
  2684. C  CMND IS CALLED BY CALC WHO HAS IDENTIFIED THE '*'
  2685. C  INDICATING A COMMAND IS DESIRED.
  2686. C
  2687. C
  2688. C
  2689. C
  2690. C   VARIABLE      USE
  2691. C
  2692. C
  2693. C  CCHAR      TEMPORARILY HOLDS A SINGLE CHARACTER.
  2694. C  DIGITS    HOLDS ASCII REPRESENTATION OF DIGITS.
  2695. C  I         TEMPORARY INDEX.
  2696. C  ID        ARGUMENT FOR SUBROUTINE DECLR. INDICATES
  2697. C            A PARTICULAR DATA TYPE.
  2698. C  IPT       POINTER FOR LINE(80).
  2699. C  ITCNTV    0 IF NO ITERATION. IF POSITIVE, INDEX
  2700. C            OF VARIABLE USED TO CONTROL ITERATION ON THAT LEVEL.
  2701. C  KIND(15)  HOLDS FIRST LETTER OF ALL LEGAL COMMANDS.
  2702. C  LEVEL     HOLDS LOGICAL I/O UNIT WHERE NEXT COMMAND COMES FROM.
  2703. C  LINE(80)  HOLDS COMMAND LINE.
  2704. C  NONBLK    POINTER FOR LINE(80).
  2705. C  RETCD     HOLDS RETURN CODE.
  2706. C  RETCD2    HOLDS RETURN CODE.
  2707. C  VIEWSW    VIEW SWITCH:
  2708. C            0 = OFF
  2709. C            1 = DISPLAY COMMAND LINES
  2710. C            2 = DISPLAY VALUE OF EXPRESSIONS
  2711. C            3 = DISPLAY ALL
  2712. C
  2713. C
  2714. C
  2715. C    SUBROUTINE CMND(RETCD)
  2716. C
  2717. C
  2718. C    EXTERNAL INDX
  2719.     InTeGer*4 LEVEL,NONBLK,LEND
  2720.     InTeGer*4  RETCD,RETCD2,VIEWSW,BASED
  2721. C    InTeGer*4 IOLVL
  2722. C    COMMON/IOLVL/IOLVL
  2723.     InTeGer*4 ZNEG,ITCNTV(6)
  2724. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2725. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2726.     InTeGer*4 RRWACT,RCLACT
  2727. C    COMMON/RCLACT/RRWACT,RCLACT
  2728.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2729.      1  IDOL7,IDOL8
  2730. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2731. C     1  IDOL7,IDOL8
  2732.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2733. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2734.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2735. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2736. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2737. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2738.     InTeGer*4 KLVL
  2739. C    COMMON/KLVL/KLVL
  2740.     InTeGer*4 IOLVL,IGOLD
  2741. C    COMMON/IOLVL/IOLVL
  2742. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2743. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2744.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2745.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2746.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2747.     Character*1 WRK(130)
  2748.     CHARACTER*1 WRKX(130),WRK2X(130)
  2749.     CHARACTER*1 WRK2(128)
  2750.     CHARACTER*35 CWRK,CWRKX,CWRK2
  2751.     CHARACTER*11 CWRK2B
  2752.     Character*1 wrk2b(11)
  2753.     EQUIVALENCE(CWRK2B(1:1),WRK2(1),wrk2b(1))
  2754.     EQUIVALENCE(CWRK2(1:1),WRK2(1))
  2755.     EQUIVALENCE(WRK(1),WRKX(1),CWRK(1:1),CWRKX(1:1))
  2756. C    EQUIVALENCE(WRK(1),CWRK),(CWRKX,WRKX(1),WRK(1))
  2757. C DEFINE SOME LARGER ARRAYS TO NULL TERMINATE WRK AND WRK2 ARRAYS.
  2758. c    EQUIVALENCE(WRK(1),WRKX(1))
  2759.     EQUIVALENCE(WRK2(1),WRK2X(1))
  2760.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  2761.     InTeGer*4 TYPE(1,1),VLEN(9)
  2762.     REAL*8 XAC,XVBLS(1,1)
  2763.     INTEGER*4 JVBLS(2,1,1)
  2764.     EQUIVALENCE(XAC,AVBLS(1,27))
  2765.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  2766.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  2767.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  2768.     CHARACTER*1 FVLD(1,1)
  2769.     COMMON/FVLDC/FVLD
  2770. C
  2771.     CHARACTER*1  LINE(80),KIND(23),ASCII(4),DEC(6),HEX(2),INT(6),
  2772.      ;  M10(2),M8(1),M16(2),OCTAL(4),REAL(3),CCHAR
  2773.     CHARACTER*1 DIGITS(16,3)
  2774. C
  2775.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  2776.     COMMON /ITERA/ITCNTV
  2777.     COMMON /DIGV/ DIGITS
  2778. C
  2779.     DATA KIND
  2780.      1/'@','A','B','C','D','E','H','I','M','N','O','R','S','V','Z'
  2781.      2,'P','W','G','Q','F','J','X','U'/
  2782. C NOTE PWGQFJX ADDED BY GCE FOR PORTACALC INTERFACE.
  2783. C  FREE: K,U,Y, + SPECIAL CHARACTERS (LIKE .,;'"#$%^, ETC.)
  2784.     DATA  ASCII/'S','C','I','I'/,  DEC/'E','C','I','M','A','L'/
  2785.     DATA  HEX/'E','X'/, INT/'N','T','E','G','E','R'/
  2786.     DATA  M10/'1','0'/,  M8/'8'/
  2787.     DATA  M16/'1','6'/
  2788.     DATA  OCTAL/'C','T','A','L'/
  2789.     DATA  REAL/'E','A','L'/
  2790. C    DATA WRKX/130*0/,WRK2X/130*0/
  2791. C
  2792. C
  2793. C
  2794. C PICK UP NON-BLANK CHARACTER AFTER '*'
  2795.     RETCD=1
  2796.     CALL GETNNB(IPT,RETCD2)
  2797.     GOTO(2,4),RETCD2
  2798.     STOP 2
  2799. 2    NONBLK=IPT
  2800. C NONBLK POINTS TO 1ST NONBLANK CHARACTER AFTER *
  2801. C
  2802.     DO 3 I=1,23
  2803.     IF (LINE(NONBLK).EQ.KIND(I)) GOTO 6
  2804. 3    CONTINUE
  2805. C
  2806. C
  2807. C UNIDENTIFIED COMMAND
  2808. 4    GOTO 995
  2809. C
  2810. C
  2811. C
  2812. C GO TO DIFFERENT SECTIONS ON THE BASIS OF THE FIRST CHARACTER
  2813. C OF THE COMMAND.
  2814. 6    GOTO (10,20,30,1000,40,50,60,70,80,90,100,110,50,
  2815.      1  130,140,210,220,250,290,330,360,480,780),I
  2816.     STOP 6
  2817. C
  2818. C
  2819. C
  2820. C
  2821. C **************************************************
  2822. C *****    *@  INDIRECT COMMAND PROCESSING    ******
  2823. C **************************************************
  2824. 10    CALL AT(RETCD)
  2825.     GOTO (1000,999),RETCD
  2826.     STOP 10
  2827. C
  2828. C
  2829. C
  2830. C
  2831. C **************************************************
  2832. C ******      *A     DECLARE TYPE ASCII       ******
  2833. C **************************************************
  2834. 20    CALL STRCMP (ASCII,4,RETCD2)
  2835.     ID=1
  2836.     GOTO (200,995),RETCD2
  2837.     STOP 20
  2838. C
  2839. C
  2840. C
  2841. C
  2842. C **************************************************
  2843. C ******       *B      BASE DEFAULT          *******
  2844. C **************************************************
  2845. 30    CONTINUE
  2846.     CALL BASCNG(RETCD2)
  2847.     IF(VIEWSW.NE.0)WRITE(11,34) BASED
  2848. 34    FORMAT(' DEFAULT BASE IS ',I2)
  2849.     GO TO (1000,999),RETCD2
  2850.     STOP 30
  2851. C
  2852. C
  2853. C
  2854. C
  2855. C ********************************************************
  2856. C **   *C   COMMENT, JUST RETURN (VIA STATEMENT 1000)   **
  2857. C ********************************************************
  2858. C
  2859. C
  2860. C
  2861. C **************************************************
  2862. C *******     *D     DECLARE TYPE DECIMAL    *******
  2863. C **************************************************
  2864. 40    CALL STRCMP(DEC,6,RETCD2)
  2865.     ID=2
  2866.     GOTO (200,995),RETCD2
  2867.     STOP 40
  2868. C
  2869. C
  2870. C **************************************************
  2871. C **********          *E   EXIT             ********
  2872. C **************************************************
  2873. 50    CONTINUE
  2874. C SET RETCD=4 ON EXIT IF EXIT COMMAND, SO CALC RETURNS TO ITS CALLER.
  2875.     IF (LEVEL.EQ.1) RETCD=4
  2876.     IF (LEVEL.EQ.1) RETURN
  2877. C    IF (LEVEL.EQ.1) CALL EXIT
  2878.     IF(ITCNTV(LEVEL).EQ.0)GOTO 55
  2879.     IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GOTO 55
  2880. C ITERATION VARIABLE IS POSITIVE SO EXECUTE FILE AGAIN
  2881.     REWIND LEVEL
  2882.     GO TO 1000
  2883. C
  2884. C NOTE THAT WHEN EXITING A LEVEL THAT WAS ITERATED, ITCNTV
  2885. C IS NOT SET TO ZERO. THIS REQUIRES THAT WHEN ENTERED AT
  2886. C SUBROUTINE 'AT' AND ITERATION IS NOT DESIRED, THAT ITCNTV
  2887. C MUST BE SET TO ZERO THERE
  2888.  
  2889. 55    CLOSE(LEVEL)
  2890.     LEVEL=LEVEL-1
  2891. 59    GOTO 1000
  2892. C
  2893. C
  2894. C
  2895. C
  2896. C
  2897. C **************************************************
  2898. C * *H DECLARE VARIABLES TO BE OF TYPE HEXADECIMAL *
  2899. C **************************************************
  2900. 60    CALL STRCMP (HEX,2,RETCD2)
  2901.     ID=3
  2902.     GOTO (200,995),RETCD2
  2903.     STOP 60
  2904. C
  2905. C
  2906. C
  2907. C
  2908. C **************************************************
  2909. C * *I DECLARE VARIABLE TO BE OF TYPE INTEGER (*4) *
  2910. C **************************************************
  2911. 70    CALL STRCMP (INT,6,RETCD2)
  2912.     ID=4
  2913.     GOTO (200,995),RETCD2
  2914.     STOP 70
  2915. C
  2916. C
  2917. C **************************************************
  2918. C *  *M  DECLARE VARIABLE TO BE MULTIPLE PRECISION *
  2919. C **************************************************
  2920. 80    CALL STRCMP (M10,2,RETCD2)
  2921.     ID=5
  2922.     GOTO (200,84),RETCD2
  2923.     STOP 80
  2924. C
  2925. C
  2926. C  SEE IF MULTIPLE PRECISION IS OCTAL
  2927. 84    CALL STRCMP (M8,1,RETCD2)
  2928.     ID=6
  2929.     GOTO (200,88),RETCD2
  2930.     STOP 84
  2931. C
  2932. C
  2933. C  SEE IF MULTIPLE PRECISION HEXADECIMAL
  2934. 88    CALL STRCMP (M16,2,RETCD2)
  2935.     ID=7
  2936.     GOTO (200,995),RETCD2
  2937.     STOP 88
  2938. C
  2939. C
  2940. C
  2941. C
  2942. C ************************************************************
  2943. C **  *N SUPPRESS PRINTING OF VARIABLES WHEN VALUES CHANGE  **
  2944. C ************************************************************
  2945. 90    VIEWSW=1
  2946.     GOTO 1000
  2947. C
  2948. C
  2949. C
  2950. C
  2951. C **************************************************
  2952. C ***  *O  DECLARE VARIABLE TO BE OF TYPE OCTAL  ***
  2953. C **************************************************
  2954. 100    CALL STRCMP (OCTAL,4,RETCD2)
  2955.     ID=8
  2956.     GOTO (200,995),RETCD2
  2957.     STOP 100
  2958. C
  2959. C
  2960. C
  2961. C
  2962. C
  2963. C **************************************************
  2964. C ***********     *R ENCOUNTERED       *************
  2965. C **************************************************
  2966. C
  2967. C  *R    SEE IF A REAL DECLARATION
  2968. 110    CALL STRCMP (REAL,3,RETCD2)
  2969.     ID=9
  2970.     GOTO (200,114),RETCD2
  2971.     STOP 110
  2972. C
  2973. C
  2974. C  OTHERWISE ASSUME A READ IS REQUIRED
  2975. 114    IF (LEVEL.NE.1) GOTO 117
  2976.     WRITE(11,116)
  2977.     GOTO 118
  2978. 116    FORMAT(' CALR>',$)
  2979. 117    WRITE (11,119) LEVEL
  2980. 119    FORMAT (' CALC<',I1,'>',$)
  2981. 118    READ (11,115,END=1000,ERR=990) LINE
  2982. 115    FORMAT (80A1)
  2983. C
  2984. C  NOTE THAT IF <CR> IS HIT AS THE ONLY INPUT, RETURN IS NORMAL
  2985. C  AND PROCESSING CONTINUES ON LEVEL (RETCD=2)
  2986.     RETCD=2
  2987.     GOTO 1000
  2988. C
  2989. C
  2990. C
  2991. C
  2992. C
  2993. C ************************************************************
  2994. C ***  *V ACTIVATE PRINTING OF VARIABLE WHEN VALUES CHANGE ***
  2995. C ************************************************************
  2996. 129    NONBLK=IPT
  2997. 130    CALL GETNNB(IPT,RETCD2)
  2998.     GO TO (129,132),RETCD2
  2999.     STOP  130
  3000. 132    CCHAR=LINE(NONBLK)
  3001.     IF(CCHAR.NE.DIGITS(10,1))GO TO 134
  3002. C
  3003. C  *VIEW 0 ENCOUNTERED
  3004.     VIEWSW=0
  3005.     GO TO 1000
  3006. 134    IF(CCHAR.NE.DIGITS(1,1))GO TO 136
  3007. C
  3008. C *VIEW 1 ENCOUNTERED
  3009.     VIEWSW=1
  3010.     GO TO 1000
  3011. 136    IF(CCHAR.NE.DIGITS(2,1))GO TO 138
  3012.     VIEWSW=2
  3013.     GO TO 1000
  3014. 138    VIEWSW=3
  3015.     GOTO 1000
  3016. C
  3017. C
  3018. C
  3019. C
  3020. C **************************************************
  3021. C **********   *Z   ZERO OUT ALL VARIABLES  ********
  3022. C **************************************************
  3023. 140    CALL ZERO
  3024.     GOTO 1000
  3025. C
  3026. C
  3027. C
  3028. C
  3029. C
  3030. C MAKE DECLARATIONS
  3031. 200    CALL DECLR(ID,RETCD2)
  3032.     GO TO(1000,999),RETCD2
  3033.     STOP 200
  3034. C
  3035. C
  3036. C
  3037. C
  3038. C
  3039. C **** ERROR PROCESSING ****
  3040. C
  3041. 990    I=27
  3042.     REWIND LEVEL
  3043.     GO TO 998
  3044. 995    I=3
  3045. 998    CALL ERRMSG(I)
  3046. 999    RETCD=3
  3047. 1000    CONTINUE
  3048.     RETURN
  3049. C
  3050. C P COMMAND - SET PLACEMENT OF PHYSICAL POSN IN SHEET
  3051. C *P WILL PROMPT FOR INPUTS OF LOCATIONS.
  3052. C
  3053. 210    CONTINUE
  3054. C
  3055.     RETCD=1
  3056.     CALL CMND2(RETCD,1)
  3057.     RETURN
  3058. C W COMMAND - WRITE % TO CURRENT PHYSICAL LOC IN SHEET. USE E32.25
  3059. C FORMAT.
  3060. C  DOES NOT PROMPT. THEREFORE, IF USED INSIDE SPREADSHEET, HAS THE
  3061. C  EFFECT OF CONVERTING CURRENT CELL'S FORMULA TO A LITERAL NUMBER
  3062. C  AND FREEZING IT THAT WAY. THEREFORE A FORMULA CONTAINING *W WILL
  3063. C  NORMALLY ONLY EXECUTE THE *W ONCE (AFTERWARDS BEING OVERWRITTEN).
  3064. C
  3065. 220    CONTINUE
  3066.     RETCD=1
  3067.     CALL CMND2(RETCD,2)
  3068. C
  3069.     RETURN
  3070. C
  3071. C *G SEEN.
  3072. C THE SYNTAX OF *G IS *G V1,V2 WHICH WILL GET VALUE OF VBLS(G1,G2)
  3073. C  AND LOAD IT INTO %. THE DIMENSIONS ARE CLAMPED TO LEGAL BOUNDS
  3074. C  AND TYPE=4 MEANS USE INTEGER, TYPE=2 CONVERTS VARIABLES TO
  3075. C  INTEGER. CALLS VARSCN TO DO THIS STUFF.
  3076. C  THIS GIVES A MEASURE OF INDIRECTION.
  3077. 250    CONTINUE
  3078.     RETCD=1
  3079. C SAY ALL'S WELL.
  3080.     CALL CMND2(RETCD,3)
  3081. C
  3082.     RETURN
  3083. C
  3084. C *Q QUERY DATABASE COMMAND
  3085. C
  3086. C
  3087. 290    CONTINUE
  3088.     RETCD=1
  3089.     CALL CMND2(RETCD,4)
  3090. C
  3091.     RETURN
  3092. C
  3093. C *F LABEL  GOTO LABEL COMMAND (CONDITIONAL)
  3094. C
  3095. C
  3096. C THE SYNTAX OF THE *F COMMAND IS :
  3097. C  *F LABEL
  3098. C  WITH THE OPERATION OF LOCATING A LINE BEGINNING WITH THE
  3099. C  STRING "*CLABEL" (SO IT IS PASSED OVER BY NORMAL CALC
  3100. C  PROCESSING). THE INPUT FILE ON IOLVL IS REWOUND AND
  3101. C  SCANNING GOES TO THE EOF OR UNTIL THE STRING IS FOUND.
  3102. C  RETCD=2 IF NO SUCH LABEL IS FOUND.
  3103. C
  3104. C  AS A FURTHER AID, IF THE % VARIABLE IS 0 OR NEGATIVE, THE
  3105. C  COMMAND IS IGNORED.
  3106. 330    CONTINUE
  3107.     RETCD=1
  3108.     CALL CMND2(RETCD,5)
  3109. C
  3110.     RETURN
  3111. C
  3112. C *J LABEL - JUST LIKE *F LABEL BUT ON CALC'S COMMAND FILES.
  3113. C I.E., FINDS A LINE STARTING WITH *CLABEL
  3114. C (NOTE IT STARTS FROM START OF FILE AND DOES THIS ONLY IF % IS POSITIVE).
  3115. C ITERATION OF COMMAND FILES REMAINS UNDER NORMAL CONTROL.
  3116. 360    CONTINUE
  3117.     RETCD=1
  3118.     CALL CMND2(RETCD,6)
  3119.     RETURN
  3120. C *X COMMAND
  3121. C  XC FILESPEC CELLNAME
  3122. C    READS FILESPEC AS A SAVED SPEADSHEET (NUMERIC OR FORMULA)
  3123. C  AND LOADS ITS VALUE INTO CURRENT CELL AND % ACCUMULATOR. DOES
  3124. C  NOT LOAD FORMULA UNLESS F SEEN. THUS 2 VARIANTS:
  3125. C   *XF FILESPEC CELLNAME    LOAD FORMULA AND VALUE
  3126. C   *XV FILESPEC CELLNAME    LOAD VALUE
  3127. C NOTE ANY CHARACTER AFTER *X THAT ISN'T "F" IS EQUIVALENT TO V FOR EASY USE.
  3128. 480    CONTINUE
  3129.     RETCD=1
  3130.     CALL CMND2(RETCD,7)
  3131.     RETURN
  3132. C *U FUNCTION ARGS
  3133. C HANDLE USER FUNCTION CALL...
  3134. 780    CONTINUE
  3135.     RETCD=1
  3136. C PASS LINE AND ARGS TO SUBROUTINE TO PARSE (EXTERNALIZE THE WORK)
  3137. C COMMON /V/ HAS DATA NEEDED FOR ARGUMENTS...
  3138.     CALL USRFCT(LINE,RETCD,WRK2)
  3139. C IF RETCD CHANGES IN USRFCT THIS ALLOWS ERROR CODES BACK.
  3140.     RETURN
  3141.     END
  3142. c -h- cmnd2.f40    Fri Aug 22 13:00:17 1986    
  3143.     SUBROUTINE CMND2(RETCD,I)
  3144. C COPYRIGHT (C) 1983 GLENN EVERHART
  3145. C ALL RIGHTS RESERVED
  3146. C
  3147. C EXTRA ROUTINES MOVED HERE FROM INSIDE CMND SO THAT THEY CAN BE OVERLAIN IN
  3148. C 256K VERSION TO GAIN A GREAT DEAL OF SPACE.
  3149.     EXTERNAL INDX
  3150.     InTeGer*4 LEVEL,NONBLK,LEND
  3151.     InTeGer*4  RETCD,RETCD2,VIEWSW,BASED
  3152. C    InTeGer*4 IOLVL
  3153. C    COMMON/IOLVL/IOLVL
  3154.     InTeGer*4 ZNEG,ITCNTV(6)
  3155. C    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  3156. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  3157.     InTeGer*4 RRWACT,RCLACT
  3158. C    COMMON/RCLACT/RRWACT,RCLACT
  3159.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  3160.      1  IDOL7,IDOL8
  3161. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  3162. C     1  IDOL7,IDOL8
  3163.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  3164. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  3165.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  3166. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  3167. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  3168. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  3169.     InTeGer*4 KLVL
  3170. C    COMMON/KLVL/KLVL
  3171.     InTeGer*4 IOLVL,IGOLD
  3172. C    COMMON/IOLVL/IOLVL
  3173. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  3174. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  3175.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  3176.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  3177.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  3178.     CHARACTER*1 WRK2(128),LETA
  3179.     CHARACTER*35 CWRK,CWRKX,CWRK2
  3180.     CHARACTER*50 CWRK50
  3181.     EQUIVALENCE (CWRK50(1:1),CWRK(1:1))
  3182.     CHARACTER*11 CWRK2B
  3183.     Character*1 wrk2b(11)
  3184.     CHARACTER*1 WRKX(130),WRK2X(130)
  3185.     Character*1 WRK(128)
  3186.     EQUIVALENCE(CWRK2B,WRK2(1),Wrk2b(1),Cwrk2)
  3187. c    EQUIVALENCE(CWRK2,WRK2(1))
  3188.     EQUIVALENCE(WRK(1),WRKX(1),CWRK(1:1),CWRKX(1:1))
  3189. C    EQUIVALENCE(WRK(1),CWRK),(CWRKX,WRKX(1),WRK(1))
  3190. C DEFINE SOME LARGER ARRAYS TO NULL TERMINATE WRK AND WRK2 ARRAYS.
  3191. c    EQUIVALENCE(WRK(1),WRKX(1))
  3192.     EQUIVALENCE(WRK2(1),WRK2X(1))
  3193.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  3194.     InTeGer*4 TYPE(1,1),VLEN(9)
  3195.     REAL*8 XAC,XVBLS(1,1)
  3196.     INTEGER*4 JVBLS(2,1,1)
  3197.     EQUIVALENCE(XAC,AVBLS(1,27))
  3198.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  3199.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  3200.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  3201.     CHARACTER*1 FVLD(1,1)
  3202.     COMMON/FVLDC/FVLD
  3203. C
  3204.     CHARACTER*1  LINE(80),CCHAR
  3205.     CHARACTER*1 DIGITS(16,3)
  3206. C
  3207.     COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
  3208.     COMMON /ITERA/ITCNTV
  3209.     COMMON /DIGV/ DIGITS
  3210. C I ARGUMENT SELECTS COMMAND.
  3211. C 1 = *P
  3212. C 2 = *W
  3213. C 3 = *G 
  3214. C 4 = *Q
  3215. C 5 = *F
  3216. C 6 = *G
  3217. C 7 = *X
  3218.     IF(I.NE.1)GOTO 7000
  3219. C *P COMMANDS
  3220. C IF THE COMMAND IS *P VAR THEN SET TO VARIABLE LOCATION.
  3221.     KK1=3
  3222.     KK2=20
  3223.     IF(LINE(3).EQ.'@')GOTO 217
  3224. C ONLY LOOK IN COLS 3-20. COLUMNS 1,2 ARE THE *W COMMAND.
  3225.     CALL VARSCN(LINE,KK1,KK2,KEK,KK,KKK,IVLD)
  3226.     IF(IVLD.NE.0)GOTO 216
  3227.     GOTO 218
  3228. 217    CONTINUE
  3229. C ALLOW *W@V1,V2 TO GOTO LOCATION OF V1,V2 (COL,ROW)
  3230. C  THIS ALLOWS PROGRAMMED ACCESS TO VARIABLES.
  3231.     L1=4
  3232.     L2=60
  3233.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1A,ID2A,IVLD1)
  3234.     IF(IVLD1.EQ.0)GOTO 1000
  3235.     CALL TYPGET(ID1A,ID2A,TYPE(1,1))
  3236.     IF(TYPE(1,1).EQ.2)GOTO 219
  3237.     CALL JVBLGT(1,ID1A,ID2A,JVBLS(1,1,1))
  3238.     LCL=JVBLS(1,1,1)
  3239.     GOTO 2200
  3240. 219    CONTINUE
  3241.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  3242.     LCL=XVBLS(1,1)
  3243. 2200    CONTINUE
  3244. C NOW HAVE COLUMN NUMBER. PASS DELIMITER (WHATEVER IT IS) AND GO ON
  3245.     L1=LSTCH+1
  3246.     L2=60
  3247. C ASSUME WE GET THERE WITHIN 60 CHARACTERS...
  3248.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1B,ID2B,IVLD2)
  3249.     IF(IVLD2.EQ.0)GOTO 1000
  3250. C SEEMS LIKE OK VARIABLE... GO AHEAD
  3251.     CALL TYPGET(ID1B,ID2B,TYPE(1,1))
  3252.     CALL JVBLGT(1,ID1B,ID2B,JVBLS(1,1,1))
  3253.     LRW=JVBLS(1,1,1)
  3254.     IF(TYPE(1,1).EQ.2)CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  3255.     IF(TYPE(1,1).EQ.2)LRW=XVBLS(1,1)
  3256. C ADJUST FOR ACCUMULATOR ROW BY ADDING 1
  3257.     LRW=LRW+1
  3258. C NOW HAVE COLUMN AND ROW NUMBERS. GET VARIABLE USING THEM AFTER
  3259. C CLAMPING TO MAX VALUES.
  3260.     LCL=MAX0(1,LCL)
  3261.     LRW=MAX0(1,LRW)
  3262.     LCL=MIN0(LCL,60)
  3263.     LRW=MIN0(LRW,301)
  3264.     KK=LCL
  3265.     KKK=LRW
  3266.     GOTO 216
  3267. 218    CONTINUE
  3268.     IF(LEVEL.EQ.1)WRITE(11,211)
  3269. 211    FORMAT(' SET PHYS LOC. COLUMN=')
  3270.     LLLV=LEVEL
  3271.     IF(LEVEL.EQ.1)LLLV=11
  3272.     READ(LLLV,212,END=700,ERR=700)KK
  3273. 212    FORMAT(I7)
  3274.     IF(LEVEL.EQ.1)WRITE(11,213)
  3275. 213    FORMAT(' SET PHYS LOC. ROW =')
  3276.     READ(LLLV,212,END=700,ERR=700)KKK
  3277.     KKK=KKK+1
  3278. 216    KK=MAX0(1,KK)
  3279.     KKK=MAX0(1,KKK)
  3280.     KK=MIN0(60,KK)
  3281.     KKK=MIN0(301,KKK)
  3282. C CLAMP TO LEGAL SIZE
  3283.     PROW=KK
  3284.     PCOL=KKK
  3285. C
  3286.     RETURN
  3287. C TERMINAL READ ERROR AND END PROCESSING
  3288. 700    CONTINUE
  3289.     IF(LEVEL.EQ.1)CLOSE(11)
  3290.     IF(LEVEL.EQ.1)OPEN(11,FILE='CON:20/100/300/40/Analy Command')
  3291.     IF(LEVEL.NE.1)REWIND LEVEL
  3292.     IF(ITCNTV(LEVEL).EQ.0)GOTO 55
  3293.     IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GOTO 55
  3294.     RETURN
  3295. 7000    CONTINUE
  3296.     IF(I.NE.2)GOTO 7200
  3297. C *W COMMANDS
  3298. C    IRX=(PCOL-1)*60+PROW
  3299.     CALL REFLEC(PCOL,PROW,IRX)
  3300.     CALL WRKFIL(IRX,WRK,0)
  3301. C    READ(7'IRX)WRK
  3302. C GET RECORD INTO MEMORY
  3303.     IF(LINE(3).EQ.'F')GOTO 224
  3304.     WRITE(CWRK(1:35),221)XAC
  3305. C    ENCODE(35,221,WRK)XAC
  3306. C PUT VARIABLE VALUE AS STRING INTO FILE BUFFER
  3307. 221    FORMAT(D32.25)
  3308.     GOTO 225
  3309. 224    CONTINUE
  3310. C WRITE AND USE LOCAL FORMAT
  3311.     WRK2(1)='('
  3312.     DO 226 K=1,9
  3313.     WRK2(1+K)=WRK(119+K)
  3314. 226    CONTINUE
  3315.     WRK2(11)=')'
  3316.     WRITE(CWRK(1:35),WRK2B)XAC
  3317. 225    CONTINUE
  3318.     DO 222 K=36,110
  3319. 222    WRK(K)=CHAR(32)
  3320.     CALL WRKFIL(IRX,WRK,1)
  3321. C    WRITE(7'IRX)WRK
  3322.     RETURN
  3323. 7200    CONTINUE
  3324.     IF(I.NE.3)GOTO 7400
  3325. C *G COMMANDS
  3326.     L1=3
  3327.     L2=60
  3328.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1A,ID2A,IVLD1)
  3329.     IF(IVLD1.EQ.0)GOTO 1000
  3330.     CALL TYPGET(ID1A,ID2A,TYPE(1,1))
  3331.     IF(TYPE(1,1).EQ.2)GOTO 251
  3332.     CALL JVBLGT(1,ID1A,ID2A,JVBLS(1,1,1))
  3333.     LCL=JVBLS(1,1,1)
  3334.     GOTO 252
  3335. 251    CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  3336.     LCL=XVBLS(1,1)
  3337. 252    CONTINUE
  3338. C NOW HAVE COLUMN NUMBER. PASS DELIMITER (WHATEVER IT IS) AND GO ON
  3339.     L1=LSTCH+1
  3340.     L2=60
  3341. C ASSUME WE GET THERE WITHIN 60 CHARACTERS...
  3342.     CALL VARSCN(LINE,L1,L2,LSTCH,ID1B,ID2B,IVLD2)
  3343.     IF(IVLD2.EQ.0)GOTO 1000
  3344. C SEEMS LIKE OK VARIABLE... GO AHEAD
  3345.     CALL JVBLGT(1,ID1B,ID2B,JVBLS(1,1,1))
  3346.     CALL TYPGET(ID1B,ID2B,TYPE(1,1))
  3347.     LRW=JVBLS(1,1,1)
  3348.     IF(TYPE(1,1).EQ.2)CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  3349.     IF(TYPE(1,1).EQ.2)LRW=XVBLS(1,1)
  3350. C ADJUST FOR ACCUMULATOR ROW BY ADDING 1
  3351.     LRW=LRW+1
  3352. C NOW HAVE COLUMN AND ROW NUMBERS. GET VARIABLE USING THEM AFTER
  3353. C CLAMPING TO MAX VALUES.
  3354.     LCL=MAX0(1,LCL)
  3355.     LRW=MAX0(1,LRW)
  3356.     LCL=MIN0(LCL,60)
  3357.     LRW=MIN0(LRW,301)
  3358. C RETURN VALUE.
  3359.     CALL TYPGET(LCL,LRW,TYPE(1,1))
  3360.     IF(TYPE(1,1).EQ.2)CALL XVBLGT(LCL,LRW,XAC)
  3361.     IF(TYPE(1,1).NE.2)CALL JVBLGT(1,LCL,LRW,JVBLS(1,1,1))
  3362.     IF(TYPE(1,1).NE.2)XAC=JVBLS(1,1,1)
  3363. C USE IMPLICIT CONVERSION FROM FORTRAN HERE. NOTE WE RETURN WITH
  3364. C THE LOOKED UP VALUE IN XAC.
  3365.     RETURN
  3366. 7400    CONTINUE
  3367.     IF(I.NE.4)GOTO 7600
  3368. C *Q COMMANDS
  3369. C *Q QUERY DATABASE COMMAND
  3370. C
  3371. C
  3372. C THIS COMMAND IS DESIGNED TO PERMIT CALC TO ACCESS SEQUENTIAL (FOR NOW)
  3373. C FILES AND PULL IN VALUES. ARRAY WRK IS USED TO HOLD THE RECORDS AND
  3374. C MAY DISPLAY WHATEVER IS DESIRED.
  3375. C
  3376. C OPERATION IS AS FOLLOWS:
  3377. C
  3378. C *QW/F filespec ?KEYSTRING? <cc>
  3379. C WHERE THE W/F FLAG MEANS WRITE TO FORMULA AT CURRENT LOC (MAYBE MODIFIED
  3380. C EARLIER BY THE *P COMMAND) AND F FLAG MEANS RETURN % AS VALUE OBTAINED BY
  3381. C ATTEMPTING A DECODE ON THE FILE LINE BETWEEN DELIMITER CHARACTERS
  3382. C cc GIVEN INSIDE  CHARACTERS. FILE IS ASSUMED TO START WITH
  3383. C "KEYSTRING" WHERE ANY CHARACTER IS A MATCH EXACTLY EXCEPT THAT
  3384. C THE _ CHARACTER INDICATES A WILDCARD.
  3385. C SPECIAL CASES:
  3386. C  IF ` IS 1ST CHAR OF KEYSTRING, RECORDS MUST HAVE KEYSTRING STARTING
  3387. C AT COL 1 (EXCLUDING THE `)
  3388. C  IF <CC> STRING HAS ` AS 1ST CHARACTER, THEN IT IS OF FORM
  3389. C <`NM> WHERE N=ASCII CODE FOR COLUMN WANTED + 32 AND M = ASCII CODE
  3390. C   FOR LENGTH DESIRED + 32
  3391. C  THIS ALLOWS POSITIONAL RETRIEVAL (THOUGH PAINFULLY)
  3392. C
  3393. C A SECOND KEYSTRING MAY BE ENTERED INSIDE A SECOND PAIR OF ? CHARACTERS TOO.
  3394. C  THE SEARCH WILL SEEK THE KEYS ANYWHERE IN THE RECORDS READ, UP TO 128
  3395. C  CHARACTERS LONG EACH.
  3396. C SECOND KEYSTRING MAY NOT BE ANCHORED TO START OF LINE.
  3397. C  AS AN ADDED ATTRACTION:
  3398. C   *QFK  OR *QFN  WON'T CLOSE LUN 4 AT END. IN ADDITION *QFN WON'T
  3399. C  CLOSE IT AT START EITHER ALLOWING SEQUENTIAL RETRIEVALS OUT OF
  3400. C  DATA FILES. DITTO *QW VARIANTS.
  3401. C    IRX=(PCOL-1)*60+PROW
  3402.     CALL REFLEC(PCOL,PROW,IRX)
  3403. C    IF(LINE(3).EQ.'W')READ(7'IRX)WRK
  3404.     IF(LINE(3).EQ.'W')CALL WRKFIL(IRX,WRK,0)
  3405.     IF(LINE(3).NE.'W'.AND.LINE(3).NE.'F')RETURN
  3406.     IL=INDX(LINE,32)
  3407.     IF(IL.GT.40)GOTO 299
  3408.     IL2=INDX(LINE(IL+1),32)
  3409.     IF(IL2.GT.38)GOTO 299
  3410. C ENSURE LUN 4 AVAILABLE
  3411.     IF(LINE(4).NE.'C'.AND.LINE(4).NE.'N')CLOSE(4)
  3412.     LINE(IL2+IL)=CHAR(0)
  3413.     IF(LINE(4).NE.'N'.AND.LINE(4).NE.'C')
  3414.      1   CALL RASSIG(4,LINE(IL+1))
  3415. C THIS MAKES LUN 4 BE THE ONE WE WANT
  3416.     LINE(IL2+IL)=CHAR(32)
  3417.     KKK=ICHAR('?')
  3418.     IQ1=INDX(LINE,KKK)
  3419. C LOCATE THE KEY
  3420.     IF(IQ1.GE.70)GOTO 299
  3421.     KKK=ICHAR('?')
  3422.     IQ2=INDX(LINE(IQ1+1),KKK)
  3423.     IF(IQ2.GE.72)GOTO 299
  3424. C NOW KNOW KEY IS IQ2-1 LONG, STARTS AT IQ1+1
  3425. C
  3426. C ALLOW DOUBLE KEYS IF ANOTHER ?? PAIR IS SEEN.
  3427.     KEYS2=0
  3428.     KKK=ICHAR('?')
  3429.     IQ3=INDX(LINE(IQ1+IQ2+1),KKK)
  3430.     IF(IQ3.GT.3)GOTO 297
  3431. C WELL, THERE'S A 2ND STRING THERE MAYBE.
  3432.     IQ4=INDX(LINE(IQ3+IQ1+IQ2+1),KKK)
  3433.     IF(IQ4.GT.30)GOTO 297
  3434.     IF(IQ4.EQ.1)GOTO 297
  3435.     KEYS2=1
  3436. C FLAG WE HAVE A SECOND KEY. SOMETHING'S THERE.
  3437.     LCL=IQ3+IQ2+IQ1+1
  3438.     LRW=LCL+IQ4-1
  3439. 297    READ(4,332,END=299,ERR=299)WRK2
  3440.     IQQ=IQ2-1
  3441.     IXX=128-IQ2
  3442. C COMPARE THE ENTIRE RECORD FOR THE KEY, MATCH ANYWHERE.
  3443.     IF(LINE(IQ1+1).NE.'`')GOTO 376
  3444. C IF 1ST CHAR OF KEY IS ` THEN SEARCH BEGINS AT LINE START ONLY. KEY IS
  3445. C 1 LESS.
  3446.     IQ1=1+IQ1
  3447.     IXX=1
  3448.     IQQ=IQQ-1
  3449. C ADJUST SO SEARCH IS 1 CHAR LESS.
  3450. 376    CONTINUE
  3451.     DO 350 KKK=1,IXX
  3452.     CALL SCMP(LINE(IQ1+1),WRK2(KKK),IQQ,ICOD)
  3453.     IF(ICOD.NE.0)GOTO 351
  3454. 350    CONTINUE
  3455. C DON'T JUST FALL THRU
  3456.     GOTO 353
  3457. 351    CONTINUE
  3458.     IF(KEYS2.EQ.0)GOTO 353
  3459. C CHECK SECOND KEY STRING IN RECORD IF ANY WAS ASKED FOR.
  3460. C (THAT'S ALL YOU GET. 2 KEYS MAX.)
  3461. C LINE(LCL) TO LINE(LRW) CONTAINS KEY.
  3462.     IXY=128-IQ4+1
  3463.     ICC=IQ4-1
  3464.     DO 354 KKK=1,IXY
  3465.     CALL SCMP(LINE(LCL),WRK2(KKK),ICC,ICOD)
  3466.     IF(ICOD.NE.0)GOTO 355
  3467. 354    CONTINUE
  3468. 355    CONTINUE
  3469. 353    IF(ICOD.EQ.0)GOTO 297
  3470. C HERE FOUND THE KEYED RECORD. NOW EXAMINE COMMAND LINE FOR
  3471. C SPECIAL CHARACTERS. IF NONE, JUST COPY THE FIRST CHARACTERS
  3472. C IN THE TEXT INTO EITHER THE BUFFER OR ENCODE THEM.
  3473.     KKK=ICHAR('<')
  3474.     IQ1=INDX(LINE,KKK)
  3475.     IF(IQ1.LE.0.OR.IQ1.GT.75)GOTO 296
  3476.     KKK=ICHAR('>')
  3477.     IQ2=INDX(LINE(IQ1+1),KKK)
  3478.     IF(IQ2.LE.0.OR.IQ2.GT.8)GOTO 296
  3479.     KKQ=ICHAR(LINE(IQ1+1))
  3480.     KK=INDX(WRK2,KKQ)
  3481. C MUNGE THE SEARCH SO THAT IF THE SPECIAL CHAR IS ` THEN THE NEXT 2
  3482. C CHARACTERS HAVE START AND LENGTH ENCODED AS ASCII CODE -32 DECIMAL
  3483. C WHICH ALLOWS FIELDS TO BE PLACED ANYWHERE (THOUGH SOMEWHAT PAINFULLY)
  3484.     IF(LINE(IQ1+1).EQ.'`')KK=ICHAR(LINE(IQ1+2))-32
  3485.     IF(KK.GT.125)GOTO 299
  3486. C NOTE THAT THE KEY FORM WOULD THEN GIVE
  3487. C  <`!@> FOR START COLUMN=1 AND LENGTH =32 (ASCII 64 = @ AND ASCII 33 = !)
  3488. C THIS MEANS USER HAS TO KNOW ASCII ORDER BUT AT LEAST IT'S IN MANUAL.
  3489.     IF(LINE(IQ1+1).EQ.'`')KKK=ICHAR(LINE(IQ1+3))-32
  3490.     KKQ=ICHAR(LINE(IQ1+2))
  3491.     IF(LINE(IQ1+1).NE.'`')KKK=INDX(WRK2(KK+1),KKQ)+KK
  3492.     GOTO 295
  3493. 296    CONTINUE
  3494. C DEFAULT, NO SPECIAL CHARS.
  3495.     KK=0
  3496.     KKK=110
  3497. 295    CONTINUE
  3498.     KL=KKK-KK-1
  3499.     KK=KK+1
  3500.     IF(LINE(3).NE.'W')GOTO 294
  3501.     KL=MIN0(KL,109)
  3502.     DO 293 N=1,KL
  3503.     WRK(N)=WRK2(KK)
  3504. 293    KK=KK+1
  3505.     WRK(KL+1)=0
  3506. C WRITE OUT THE RECORD'S KEY PART INTO SHEET FILE
  3507.     CALL WRKFIL(IRX,WRK,1)
  3508. C    WRITE(7'IRX)WRK
  3509.     XAC=1.
  3510.     GOTO 298
  3511. 294    CONTINUE
  3512. C FLOAT THE VALUE, RETURN IN XAC
  3513.     DO 750 N=1,35
  3514.     WRK(N)=CHAR(32)
  3515.     IF(N.LE.KL)WRK(N)=WRK2(KK-1+N)
  3516. 750    CONTINUE
  3517.     READ(CWRK(1:35),221,ERR=299)XAC
  3518. C    DECODE(KL,221,WRK2(KK),ERR=299)XAC
  3519. 298    CONTINUE
  3520. C IF IT'S A KEEP OR NEXT TYPE OPERATION, LEAVE LUN 4 OPEN.
  3521. C FIRST ONE MUST BE A KEEP (TO OPEN FILE IN THE FIRST PLACE)
  3522. C AND SUBSEQUENT OPERATIONS MAY BE A N OPERATIONS, WHICH
  3523. C WILL JUST CONTINUE SEQUENTIAL READIN OF DATA. USER HAS TO
  3524. C KEEP TRACK. NOTE RETURN VALUE IS -999999. (6 9'S) IF WE
  3525. C FAIL AND HAVE TO CLOSE FILE.
  3526.     IF(LINE(4).EQ.'K'.OR.LINE(4).EQ.'N')RETURN
  3527.     CLOSE(4)
  3528.     RETURN
  3529. 299    CONTINUE
  3530. C RETURN -999999 IF WE FAIL IN FINDING FILE.
  3531.     XAC=-999999.
  3532.     CLOSE(4)
  3533. C    COME HERE FOR NON-RECOVERABLE ERRORS IN FORMAT TOO.
  3534. C
  3535.     RETURN
  3536. 7600    CONTINUE
  3537.     IF(I.NE.5)GOTO 7800
  3538. C *F COMMANDS
  3539.     IF(XAC.LE.0)RETURN
  3540.     IF(IOLVL.NE.11)REWIND IOLVL
  3541.     IF(IOLVL.EQ.11)RETURN
  3542. 333    READ(IOLVL,332,END=331,ERR=331)WRK
  3543. 332    FORMAT(128A1)
  3544.     IF(WRK(1).NE.'*'.OR.WRK(2).NE.'C')GOTO 333
  3545.     ISSL=2
  3546.     ISSS=2
  3547.     IF(LINE(3).EQ.' ')ISSL=3
  3548.     IF(WRK(3).EQ.' ')ISSS=3
  3549.     CALL SCMP(LINE(ISSL),WRK(ISSS),80,ICODE)
  3550.     IF(ICODE.EQ.0)GOTO 333
  3551.     RETURN
  3552. C ERROR ENTRY WHERE WE SEE WE FAILED TO FIND LABEL.
  3553. 331    CONTINUE
  3554.     IF(IOLVL.NE.11)CLOSE(IOLVL)
  3555.     IOLVL=11
  3556.     RETCD=2
  3557. C
  3558.     RETURN
  3559. 7800    CONTINUE
  3560.     IF(I.NE.6)GOTO 8000
  3561. C *G
  3562.     IF(LEVEL.EQ.1.OR.XAC.LE.0)RETURN
  3563.     REWIND LEVEL
  3564. 363    READ(LEVEL,362,END=55,ERR=55)WRK
  3565. 362    FORMAT(128A1)
  3566.     IF(WRK(1).NE.'*'.OR.WRK(2).NE.'C')GOTO 363
  3567.     ISSL=2
  3568.     ISSS=2
  3569.     IF(LINE(3).EQ.' ')ISSL=3
  3570.     IF(WRK(3).EQ.' ')ISSS=3
  3571.     CALL SCMP(LINE(ISSL),WRK(ISSS),80,ICODE)
  3572.     IF(ICODE.EQ.0)GOTO 363
  3573. C
  3574.     RETURN
  3575. 8000    CONTINUE
  3576.     IF(I.NE.7)GOTO 8200
  3577. C *X COMMANDS
  3578. C NOW GET THE ARGS
  3579.     JFFG=0
  3580.     IF(LINE(3).EQ.'F')JFFG=1
  3581. C NOW HAVE FORMULA FLAG.
  3582.     IQ3=4
  3583. C ALLOW 1 SPACE OPTIONALLY
  3584.     IF(LINE(IQ3).EQ.' ')IQ3=5
  3585.     IQ1=INDX(LINE(IQ3),32)
  3586.     IQ1=IQ1+IQ3-1
  3587. C NULL TERMINATE FILENAME WHILE PARSING IT (DON'T LET ASSIGN SEE VBL NAME)
  3588.     LINE(IQ1)=0
  3589.     CLOSE(4)
  3590. 9770    CALL RASSIG(4,LINE(IQ3))
  3591. C REPLACE THE SPACE FOR VARSCN'S SIGHT
  3592.     LINE(IQ1)=CHAR(32)
  3593. C IQ1 NOW HAS START INDEX FOR VARSCN DESIRED... GO GET VRBL NAME.
  3594.     KK1=IQ1
  3595.     KK2=IQ1+20
  3596.     CALL VARSCN(LINE,KK1,KK2,KEK,KK,KKK,IVLD)
  3597.     IF(IVLD.LE.0)GOTO 481
  3598. C GOT VALID VARIABLE NAME. KK,KKK ARE ROW,COL
  3599. C NOW WE KNOW HOW TO RETRIEVE THE DATA OFF FILE IN UNIT 4
  3600. C READ INTO WRK ARRAY TILL WE GET IT.
  3601.     IQ3=KK
  3602.     IQ4=KKK-1
  3603. 483    READ(4,332,END=488,ERR=488)WRK
  3604. C IGNORE TITLE
  3605. 486    CONTINUE
  3606. C NOTE WE READ IN THE NUMBER IN NUMERIC FORMAT. EASIER THAT WAY.
  3607. c    IF(JFFG.EQ.0)READ(4,484,END=488,ERR=488)IRRW,ICCL,XYVAL
  3608. c    IF(JFFG.NE.0)READ(4,489,END=488,ERR=488)IRRW,ICCL,
  3609. c     1  (WRK(IV),IV=1,110)
  3610. c484    FORMAT(1X,I5,1X,I5,1X,E50.35)
  3611. c489    FORMAT(1X,I5,1X,I5,1X,110A1)
  3612.     READ(4,484,END=488,ERR=488)LETA,IRRW,ICCL,
  3613.      1  (WRK(IV),IV=1,110)
  3614. C ALWAYS READ TEXT AS ALPHA
  3615.     READ(CWRK50(1:50),6486,ERR=5486)XYVAL
  3616. C DECODE AND STORE IN XYVAL IF POSSIBLE
  3617. 6486    FORMAT(BN,D50.35)
  3618. 5486    CONTINUE
  3619. C HACK OUT TRAILING BLANKS
  3620.     DO 5322 IV=1,110
  3621.     IVV=111-IV
  3622.     IF(ICHAR(WRK(IVV)).GT.32)GOTO 5323
  3623.     WRK(IVV)=CHAR(0)
  3624. 5322    CONTINUE
  3625. 5323    CONTINUE
  3626. C &&&&
  3627. 484    FORMAT(1A1,I5,1X,I5,1X,110A1,50A1)
  3628.     READ(4,485,END=488,ERR=488)LFVLD,(WRK(IV),IV=120,128),KKTYP
  3629. C ALLOW FLAG OF 3 FOR NUMERIC,RECALCULATE... 2 FOR NUMERIC, NO RECALC.
  3630. C 1 CONTINUES TO MEAN ALWAYS RECALCULATE.
  3631.     IF(LFVLD.LT.-1)LFVLD=-3
  3632.     IF(LFVLD.GT.1)LFVLD=3
  3633. C
  3634. 485    FORMAT(I3,1X,9A1,1X,I5)
  3635. C READS IN AN ENTRY OF SAVED SHEET. TEST IF IN OUR RANGE.
  3636.     IF(IRRW.EQ.IQ3.AND.ICCL.EQ.IQ4)GOTO 487
  3637.     GOTO 486
  3638. 487    CONTINUE
  3639. C SUCCESS. NOW FILL IN VALUE OR FORMULA.
  3640.     IF(JFFG.EQ.0)GOTO 6487
  3641. C IF READING IN FORMULA, TRY AND GET VALUE OUT OF VALUE
  3642. C RECORD
  3643.     IF(LETA.NE.'p')GOTO 6487
  3644. C OK, THIS IS A VALUE RECORD WHICH SHOULD BE IMMEDIATELY FOLLOWED
  3645. C BY A FORMULA RECORD.
  3646. C   JUST DECODE THE VALUE AND RECORD IT.
  3647. C  ... ACTUALLY IT'S ALREADY DECODED SO JUST RECORD IT.
  3648.     CALL XVBLST(PROW,PCOL,XYVAL)
  3649.     XAC=XYVAL
  3650. C GO BACK AND GET FORMULA
  3651.     GOTO 486
  3652. 6487    CONTINUE
  3653. C    IRX=(PCOL-1)*60+PROW
  3654.     CALL REFLEC(PCOL,PROW,IRX)
  3655.     WRK(118)=CHAR(15)
  3656.     WRK(119)=CHAR(LFVLD)
  3657.     CALL FVLDST(PROW,PCOL,LFVLD)
  3658. C    FVLD(PROW,PCOL)=LFVLD
  3659. C SET UP TO SAVE FORMULA.
  3660. C SAVE EITHER FORMULA OR VALUE.
  3661.     IF(JFFG.EQ.0)GOTO 4890
  3662.     CALL CA2E(WRK,WRK2)
  3663.     CALL WRKFIL(IRX,WRK2,1)
  3664.     GOTO 488
  3665. 4890    CONTINUE
  3666. C SET UP NUMBER IF HERE.
  3667.     CALL TYPSET(PROW,PCOL,KKTYP)
  3668. C    TYPE(PROW,PCOL)=KKTYP
  3669.     CALL FVLDST(PROW,PCOL,LFVLD)
  3670. C    FVLD(PROW,PCOL)=LFVLD
  3671.     CALL XVBLST(PROW,PCOL,XYVAL)
  3672. C    XVBLS(PROW,PCOL)=XYVAL
  3673.     XAC=XYVAL
  3674. 488    CONTINUE
  3675.     CLOSE(4)
  3676.     RETURN
  3677. 481    CONTINUE
  3678.     CLOSE(4)
  3679.     RETCD=2
  3680. C
  3681.     RETURN
  3682. 8200    CONTINUE
  3683. 55    CLOSE(LEVEL)
  3684.     LEVEL=LEVEL-1
  3685. 1000    CONTINUE
  3686.     RETURN
  3687.     END
  3688. c -h- contyp.for    Fri Aug 22 13:00:17 1986    
  3689.     SUBROUTINE CONTYP (STACK,INDXX,OLDTYP,NEWTYP,RETCD)
  3690. C COPYRIGHT (C) 1983 GLENN EVERHART
  3691. C ALL RIGHTS RESERVED
  3692. C 60=MAX REAL ROWS
  3693. C 301=MAX REAL COLS
  3694. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  3695. C VBLS AND TYPE DIMENSIONED 60,301
  3696. C *                                                *
  3697. C *            SUBROUTINE CONTYP                   *
  3698. C
  3699. C
  3700. C  CONVERTS CONSTANT IN STACK(I,INDXX) FROM OLDTYP TO NEWTYP
  3701. C  IF OLDTYP.EQ.NEWTYP A RETURN IS MADE IMMEDIATELY.
  3702. C  NOTE THAT TYPE(INDXX) IS NOT CHANGED BY THIS ROUTINE
  3703. C  TYPE CODES:
  3704. C
  3705. C    0    NO CHANGE
  3706. C    1    ASCII
  3707. C    2    DECIMAL
  3708. C    3    HEXADECIMAL
  3709. C    4    INTEGER
  3710. c note: multiple precision conversions diked out
  3711. C    5    M10
  3712. C    6    M8
  3713. C    7    M16
  3714. C    8    OCTAL
  3715. C    9    REAL
  3716. C
  3717. C  RETCD    MEANING
  3718. C
  3719. C    1    O.K.
  3720. C    2    ERROR
  3721. C
  3722. C
  3723. C   MODIFY CLASSES:  M3,M4,M8
  3724. C
  3725. C  CONTYP CALLS:
  3726. C
  3727. C   ERRMSG   PRINTS OUT ERROR MESSAGES
  3728. C   MULCON   CONVERTS MULTIPLE PRECISION TO MULTIPLE PRECISION
  3729. C            OF A DIFFERENT BASE
  3730. C
  3731. C
  3732. C
  3733. C  CONTYP IS CALLED BY
  3734. C
  3735. C   CALUN    CALCULATES UNARY OPERATIONS
  3736. C   CALBIN   CALCULATES BINARY OPERATIONS
  3737. C   VARIABLE     USE
  3738. C
  3739. C  BASE        HOLDS BASE OR POWERS OF THAT BASE (INTEGER*4).
  3740. C  BASVEC      HOLDS LEGAL BASES: 8,10, AND 16
  3741. C  EIGHT(8)    CHARACTER*1 ARRAY TO PICK OFF REAL*8 VALUES.
  3742. C  FOUR(4)     CHARACTER*1 ARRAY TO PICK OFF INTEGER*4 VALUES.
  3743. C  I,J,M       TEMPORARY VALUES.
  3744. C  IBASE       HOLDS BASE OF A NUMBER WHEN BASE HOLDS THE POWERS
  3745. C              OF THAT BASE.
  3746. C  IEND        HOLDS THE NUMBER OF MULTIPLE PRECISION DIGITS THAT
  3747. C              WILL BE PICKED UP WHEN CONVERTING TO INTEGER*4.
  3748. C  INDXX       POINTER TO VARIABLE BEING CONVERTED.
  3749. C  INT         HOLDS INTEGER*4 VALUES EQUIVALENCED TO VECTOR FOUR.
  3750. C  IS          TEMPORARILY HOLDS MULTIPLE PRECISION BASE 8 OR BASE
  3751. C              16 DIGITS.
  3752. C  IS2         TEMPORARILY HOLDS A DIGIT VALUE WHEN CHECKING MULTIPLE
  3753. C              PRECISION BASE 8 AND BASE 16 NUMBERS TO SEE IF THEY
  3754. C              ARE TOO LARGE TO FIT IN INTEGER*4.
  3755. C  ISGN        USED WHEN DETERMINING THE MAXIMUM NUMBER THAT CAN BE
  3756. C              HELD BY INTEGER*4. 1=POSITIVE, 2= NEGATIVE. ALSO HOLDS
  3757. C              0 OR 7 FOR BASE 8 MAXIMUM NUMBER CHECK. HOLDS 0 OR 15
  3758. C              FOR BASE 16 MAXIMUM NUMBER CHECK.
  3759.  
  3760. C  K           TEMPORARILY HOLDS INTEGER*4 VALUES.
  3761. C  NEWTYP      NEW DATA TYPE REQUESTED.
  3762. C  OLDTYP      DATA TYPE OF THE VARIABLE TO BE CONVERTED.
  3763. C  RBASE       BASE WHEN CONVERTING FROM MULTIPLE PRECISION TO REAL*8.
  3764. C  REAL        HOLDS REAL*8 VALUES. EQUIVALENCED TO ARRAY EIGHT.
  3765. C  RETCD       RETURN CODE. 1=O.K.  2=ERROR.
  3766. C  RPOWER      HOLDS POWERS OF RBASE WHEN CONVERTING FROM MULTIPLE
  3767. C              PRECISION TO REAL*8.
  3768. C  STACK(I,INDXX)  HOLDS VARIABLE TO BE CONVERTED.
  3769. C
  3770. C
  3771. C    SUBROUTINE CONTYP (STACK,INDXX,OLDTYP,NEWTYP,RETCD)
  3772. C
  3773.     REAL*8 REAL,RBASE,RPOWER,DFLOAT
  3774. C
  3775.     INTEGER*4 K,INT,BASE
  3776. C
  3777.     InTeGer*4 OLDTYP,NEWTYP,RETCD,BASVEC(3),INDXX
  3778.     InTeGer*4 MAX10(10,2)
  3779.     InTeGer*4 I,M,J
  3780.     InTeGer*4 ISGN,IS,IS2
  3781. C
  3782.     CHARACTER*1 EIGHT(8),FOUR(4)
  3783.     CHARACTER*1 STACK(8,40)
  3784. C
  3785.     EQUIVALENCE (FOUR,INT),(REAL,EIGHT)
  3786. C
  3787.     DATA BASVEC/10,8,16/
  3788.     DATA MAX10/2,1,4,7,4,8,3,6,4,7,2,1,4,7,4,8,3,6,4,8/
  3789. C
  3790. C
  3791. C  SET DEFAULT RETURN CODE
  3792.     RETCD=1
  3793.     IF(OLDTYP.GT.0)GO TO 910
  3794. C
  3795. C VARIABLE UNDEFINED
  3796.     CALL ERRMSG(16)
  3797.     RETCD=2
  3798.     RETURN
  3799. C
  3800. C
  3801. C
  3802. 910    IF(NEWTYP.EQ.0) RETURN
  3803.     IF (OLDTYP.EQ.NEWTYP) RETURN
  3804.     GOTO (1000,2000,3000,3000,4000,5000,6000,3000,2000), OLDTYP
  3805.     STOP 1000
  3806. C
  3807. C
  3808. C
  3809. C **************************************************
  3810. C **************  OLDTYP = ASCII  ******************
  3811. C **************************************************
  3812. C
  3813. C  START BY CONVERTING TO INTEGER*4
  3814. 1000    CONTINUE
  3815. C
  3816. C
  3817. C  IF INTEGER, HEXADECIMAL OR OCTAL, ALMOST DONE
  3818.     DO 1002 I=2,8
  3819. 1002    STACK(I,INDXX)=0
  3820.     IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
  3821. C
  3822. C
  3823. C
  3824.     DO 1008 I=1,4
  3825. 1008    FOUR(I)=STACK(I,INDXX)
  3826.     IF (NEWTYP.EQ.2.OR.NEWTYP.EQ.9) GOTO 1200
  3827. C
  3828. C
  3829. C  MULTIPLE PRECISION
  3830. 1010    continue
  3831.     RETURN
  3832. C
  3833. C
  3834. C  DECIMAL OR REAL
  3835. 1200    REAL=DFLOAT(INT)
  3836.     DO 1210 I=1,8
  3837. 1210    STACK(I,INDXX)=EIGHT(I)
  3838.     RETURN
  3839. C
  3840. C
  3841. C
  3842. C **************************************************
  3843. C *********  OLDTYP = DECIMAL OR REAL  *************
  3844. C **************************************************
  3845. C
  3846. 2000    IF (NEWTYP.EQ.2.OR.NEWTYP.EQ.9) RETURN
  3847. C
  3848. C
  3849.     DO 2002 I=1,8
  3850. 2002    EIGHT(I)=STACK(I,INDXX)
  3851. C
  3852. C
  3853. C  ZERO STACK(I,INDXX)
  3854.     DO 2004 I=1,8
  3855. 2004    STACK(I,INDXX)=CHAR(0)
  3856. C
  3857. C
  3858. C  CONVERT TO INTEGER
  3859. C  MAKE SURE CONVERSION DOESN'T BLOW UP
  3860.     IF(REAL.LT.-2147483648.D0.OR.REAL.GT.2147483647.D0)
  3861.      1 GOTO 6050
  3862. C
  3863. C
  3864. C
  3865. 2007    INT=REAL
  3866. C
  3867. C SEE IF NEWTYP IS MULTIPLE PRECISION
  3868.     IF (NEWTYP.GE.5.AND.NEWTYP.LE.7) GOTO 1010
  3869.     DO 2008 I=1,4
  3870. 2008    STACK(I,INDXX)=FOUR(I)
  3871. C
  3872. C RETURN IF TYPE IS INTEGER, HEX, OR OCTAL
  3873.     IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
  3874. C
  3875. C ASCII SO CLEAR OUT BYES 2,3, AND 4
  3876. 2009    DO 2010 I=2,4
  3877. 2010    STACK(I,INDXX)=CHAR(0)
  3878.     RETURN
  3879. C
  3880. C
  3881. C
  3882. C
  3883. C
  3884. C
  3885. C **************************************************
  3886. C *******  OLDTYP = INTEGER, HEX, OR OCTAL  ********
  3887. C **************************************************
  3888. C
  3889. 3000    IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
  3890.     DO 3002 I=1,4
  3891. 3002    FOUR(I)=STACK(I,INDXX)
  3892. C
  3893. C SEE IF NEWTYP IS ASCII
  3894.     IF (NEWTYP.EQ.1) GOTO 2009
  3895. C
  3896. C IF NOT REAL*8 THEN IT IS MULTIPLE PRECISION (PROCESS AT 1010)
  3897.     IF (NEWTYP.NE.2.AND.NEWTYP.NE.9) GOTO 1010
  3898. C
  3899. C PROCESS AS REAL*8
  3900.     GOTO 1200
  3901. C
  3902. C *************  OLDTYP = M10  *********************
  3903. C
  3904. 4000    CONTINUE
  3905.     RETURN
  3906. 4040    continue
  3907.     RETURN
  3908. C
  3909. C **************  OLDTYP = M8  *********************
  3910. C
  3911. 5000    CONTINUE
  3912. C ***************  OLDTYP = M16  *******************
  3913. C
  3914. 6000    CONTINUE
  3915.     RETURN
  3916. C
  3917. C ***** ERROR RETURN ******
  3918. 6050    RETCD=2
  3919. C ILLEGAL CONVERSION ATTEMPTED.
  3920.     CALL ERRMSG(26)
  3921.     RETURN
  3922. C
  3923.     END
  3924. c -h- imask.for    Fri Aug 22 12:54:45 1986    
  3925.     INTEGER FUNCTION IMASK(I1,I2)
  3926.     InTeGer*4 I1,I2
  3927.     InTeGer*4 IXX
  3928.     IXX=I1.AND.I2
  3929.     IMASK=IXX
  3930.     RETURN
  3931.     END
  3932.     REAL*8 FUNCTION DFLOAT(IN)
  3933.     INTEGER IN
  3934.     REAL*8 XX
  3935.     XX=IN
  3936.     DFLOAT=XX
  3937.     RETURN
  3938.     END
  3939.